Single Patient Record Back-up
A method to obtain single patient record from VistA - Thanks to Alan for the solution.
Here is the Full documentation of the very basic starter program for selecting one patients file and printing there name and ssn. About five VistA routines are included for reference.
=======================================
USER>D ^%CD
Namespace: VISTA You're in namespace VISTA Default directory is c:\cachesys\mgr\vista\ VISTA>
VISTA>S DUZ=10000000020
VISTA>D ^XUP
Setting up programmer environment This is a TEST account.
Terminal Type set to: C-VT320
Select OPTION NAME: VISTA>
VISTA>D ^NAM3SSN
Select PATIENT NAME: ONE
1 ONE,IMAGEPATIENT 4-15-53 666061001 NO NSC
VETERAN
2 ONE,INPATIENT 3-9-45 666000801 NO NSC VETERAN
3 ONE,OUTPATIENT 3-9-45 666000601 NO NSC
VETERAN
4 ONE,PATIENT 4-7-35 666000001 YES SC VETERAN
5 ONEHUNDRED,INPATIENT 3-9-45 666000900 NO NSC
VETERAN
ENTER '^' TO STOP, OR CHOOSE 1-5: 4 ONE,PATIENT 4-7-35 666000001 YES SC VETERAN
Enrollment Priority: GROUP 3 Category: IN PROCESS End Date:
Name: ONE,PATIENT SSN: 666000001
VISTA>
NAM3SSN ; Lab 9; TEST VISTA SELECT PATIENT NAME: W NAME & SSN; AHR;
09/14/2009
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; FROM:
; DGPHIST ;WASH/ERC - PURPLE HEART REQUEST HISTORY ;23 AUG 00 ;
; 5.3;Registration;**343**,Aug 13, 1993
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
EN ;Entry point
;
N DGDFN,DGPAT,DGNAM,DGSSN
I DTIME="" S DTIME=30 ; added 1 line; TIMEOUT 4 READ set if ^XUP not
run
S DGDFN=$$GETDFN()
Q:DGDFN'>0
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Searching for GETDFN() in *.*
;
; ALL THREE EXAMPLES OF GETDFN() ARE INCLUDED FOR REFERENCE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;DGPHIST.int(9): S DGDFN=$$GETDFN()
;DGPHIST.int(22): GETDFN() ;Ask the user to select patient
;EASECPC.int(36): GETDFN() ; Get the veteran's DFN
;NAM3SSN.int(11): S DGDFN=$$GETDFN()
;NAM3SSN.int(30): ; THIS NEXT GETDFN() NOT IN USE INCLUDED FOR
REFERENCE
;NAM3SSN.int(36): ;GETDFN() ;Ask the user to select patient
;NAM3SSN.int(54): GETDFN() ;Get pointer to PATIENT file (#2)
;NAM3SSN.mac(11): S DGDFN=$$GETDFN()
;NAM3SSN.mac(30): ; THIS NEXT GETDFN() NOT IN USE INCLUDED FOR
REFERENCE
;NAM3SSN.mac(36): ;GETDFN() ;Ask the user to select patient
;NAM3SSN.mac(54): GETDFN() ;Get pointer to PATIENT file (#2)
;VAFCMS01.int(10): S DFN=$$GETDFN()
;VAFCMS01.int(18): GETDFN() ;Get pointer to PATIENT file (#2)
;VAFCMS01.int(225): S DFN=$$GETDFN()
;Found 14 occurrence/s in 5 file/s.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; --->>> taking out the $$GETPAT(DGDFN) code because it is not
simple.
;
;S DGPAT=$$GETPAT(DGDFN)
;Q:$P(DGPAT,U)=""
;S DGNAM=$P(DGPAT,U),DGSSN=$P(DGPAT,U,2)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
S DGNAM=$$NAME(DGDFN)
;
S DGSSN=$$SSN(DGDFN)
;
W !!,"Name: ",DGNAM," ","SSN: ",DGSSN,! ; Only line I have written
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; THIS CODE IS BEING USED
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; FROM:
; DGPHIST ;WASH/ERC - PURPLE HEART REQUEST HISTORY
;23 AUG 00 ;;5.3;Registration;**343**,Aug 13, 1993
;
; this code commented out for reference to the entry point above.
GETDFN() ;Ask the user to select patient
;
; Input: none
;
; Output: DFN
;
N DIC,X,Y
S DIC="^DPT(",DIC(0)="AEMQ"
D ^DIC
Q $S(+Y>0:+Y,1:0)
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; FROM:
; VAFCMS01 ;BP-CIOFO/JRP - ADMISSION RETRANSMISSION;8/3/1998 ;
; 5.3;Registration;**209**;Aug 13, 1993
;
; THIS NEXT GETDFN() NOT IN USE INCLUDED FOR REFERENCE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; GETDFN() ;Get pointer to PATIENT file (#2)
; Input : None
;Output : DFN - Pointer to PATIENT file (#2)
; -1 - No entry selected
;
; N DIC,X,Y,DTOUT,DUOUT
; S DIC="^DPT("
; S DIC(0)="AEMNQZ"
; D ^DIC
; Q +Y
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
;EASECPC ;ALB/PHH,CKN,LBD,AMA,SCK - LTC Copayment Report; 29-AUG-2001
;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,19,24,34,40,79**;Mar 15,
2001;Build 3
;
; This routine prints a report of calculated LTC copayments for a
veteran.
; It is called by menu option EASEC LTC COPAY PRINT
;
; EN N DFN,EASRPT,EASADM,EASRDT,MAXRT,DGMTI,DGMTDT
; Select which report to print (1=Institutional (IP); 2=Non-
Institutional (OP))
; S EASRPT=$$RPT Q:'EASRPT
; Select Patient
; S DFN=$$GETDFN Q:'DFN
; S EASADM=""
; Get the LTC admission date (if EASRPT=1)
; I EASRPT=1 S EASADM=$$ADMDT Q:'EASADM
; E S EASADM="" ;EAS*1.0*79
; Get start date for report
; S EASRDT=$$RPTDT Q:'EASRDT
;EAS*1.0*79 - moved from 4 lines up, and added EASADM as a parameter
;Set EASADM to the report date for Non-Institutional (OP) reports
; I EASRPT=2 S EASADM=EASRDT
; Get most recent LTC Copay Test for patient and set up LTC variables
; I '$$GETLTC(DFN,EASADM) Q
; Run the report
; D QUE
; Q
; RPT() ; Select which report to print
; Input: None
; Output: Y - Report Type (1=Institutional (IP); 2=Non-Institutional
(OP); 0=Quit)
; N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
; W !!,"Report of Calculated Long Term Care Copayments"
; W !,"=============================================="
; S DIR(0)="S^1:Institutional (Inpatient);2:Non-Institutional
(Outpatient)"
; S DIR("A")="Enter 1 or 2"
; D ^DIR I 'Y!($D(DTOUT))!($D(DUOUT)) Q 0
; Q Y
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; GETDFN() ; Get the veteran's DFN
; N DIC,DTOUT,DUOUT,X,Y
; W !
; S DIC="^DPT(",DIC(0)="AEMZQ",DIC("S")="I $D(^DGMT(408.31,""AID"",
3,+Y))"
; D ^DIC
; Q:$D(DTOUT)!($D(DUOUT)) 0
; Q:Y<0 0
; Q +Y
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; MORE ROUTINE ....
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; FROM:
; DGENPTA ;ALB/CJM - Patient API - Retrieve Data; 13 JUN 1997
;;5.3;Registration;**121,122,147**;08/13/93
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
SSN(DFN) ;
;Description: Function returns the patient's SSN, or "" on failure.
;
Q:'DFN ""
Q $P($G(^DPT(DFN,0)),"^",9)
;
NAME(DFN) ;
;Description: Function returns the patient's NAME, or "" on failure.
;
Q:'DFN ""
Q $P($G(^DPT(DFN,0)),"^")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
QUIT ; END NAM2SSN
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
QUIT ; MAKE SURE ENDING HERE
;
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
;GETPAT(DFN) ;
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Searching for GETPAT(DFN) in *.*
;
;DGPHIST.int(33): GETPAT(DFN) ; get patient name and ssn
;NAM3SSN.int(89): ;GETPAT(DFN) ;
;NAM3SSN.int(106): ; EXTERNAL PROCEDURE USED BY GETPAT(DFN) INCLUDED
FOR REFERENCE
;NAM3SSN.mac(89): ;GETPAT(DFN) ;
;NAM3SSN.mac(106): ; EXTERNAL PROCEDURE USED BY GETPAT(DFN) INCLUDED
FOR REFERENCE
;PSOTPCLP.int(130): D GETPAT(DFN)
;PSOTPCLP.int(148): GETPAT(DFN) ;GET PATIENT DATA
;Found 7 occurrence/s in 4 file/s.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; Input: DFN - patient IEN
;
; Output:
; Function value: patient name^SSN
;
;N VADM,DGNAM,DGSSN
;S (DGNAM,DGSSN)=""
;I $G(DFN)>0 D
;. D ^VADPT ; CALLS THIS EXTERNAL PROCEDURE
;. S DGNAM=VADM(1)
;. S DGSSN=$P(VADM(2),U,2)
;Q DGNAM_"^"_DGSSN
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; EXTERNAL PROCEDURE USED BY GETPAT(DFN) INCLUDED FOR REFERENCE
;
;VADPT ;ALB/MRL/MJK - RETURN PATIENT VARIABLE ARRAYS [DRIVER];07 DEC
1988
;;5.3;Registration;**193,343,389,415,489,498**;Aug 13, 1993
;DFN = Patient IFN [if not passed entire array returned as null]
;
;DEM ;Demographic Variables
;S VAN=1,VAN(1)=12,VAV="VADM" D ^VADPT0 Q
;
;OPD ;Other Patient Data
;S VAN=2,VAN(1)=7,VAV="VAPD" D ^VADPT0 Q
;
;ADD ;Current Address
;S VAN=3,VAN(1)=22,VAV="VAPA" D ^VADPT0 Q
;
;OAD ;Other Patient Variables
;S VAN=4,VAN(1)=11,VAV="VAOA" D ^VADPT0 Q
;
;INP ;Inpatient Data [pre-version 5]
;N VAINDTT S VAN=5,VAN(1)=11,VAV="VAIN",VAINDTT=$G(VAINDT) N VAINDT
S:VAINDTT VAINDT=$$DATIM(VAINDTT) D ^VADPT0 Q
;
;IN5 ;Inpatient Data [v5.0 and above]
;N VAINDTT S VAN=6,VAN(1)=19,VAV=$S('$D(VAIP("V")):"VAIP",VAIP("V")'?
1A.E:"VAIP",1:VAIP("V")),VAINDTT=$G(VAIP("D")) S:$L(VAINDTT) VAIP("D") =VAINDTT S:VAINDTT VAIP("D")=$$DATIM(VAINDTT) D ^VADPT0 S:$L(VAINDTT) VAIP("D")=VAINDTT Q
;
;ELIG ;Eligibility Information
;S VAN=7,VAN(1)=9,VAV="VAEL" D ^VADPT0 Q
;
;MB ;Monetary Benefits
;S VAN=8,VAN(1)=9,VAV="VAMB" D ^VADPT0 Q
;
;SVC ;Service Information
;S VAN=9,VAN(1)=9,VAV="VASV" D ^VADPT0 Q
;
;REG ;Registration data
;S VAN=10,VAV="VARP" D ^VADPT0 Q
;
;SDE ;Enrollment Information
;S VAN=11,VAV="VAEN" D ^VADPT0 Q
;
;SDA ;Appointment Information
;S VAN=12,VAV="VASD" D ^VADPT0 Q
;
;PID ;Patient Id
;S VAN=13,VAV="VA" D ^VADPT0 Q
;
;TESTPAT(DFN) ;Test patient ? Returns 0 (No) or 1 (Yes)
;S DFN=+$G(DFN) I 'DFN Q 0
;I $D(^DPT("ATEST",DFN)) Q 1
;N NODE S NODE=$G(^DPT(DFN,0))
;I $P(NODE,"^",21)=1 Q 1
;I $E($P(NODE,"^",9),1,5)="00000" Q 1
;Q 0
;
;V5 S X=$S($D(^DG(43,1,"VERSION")):+^("VERSION"),1:""),VADPT("V")=$S
(X<5:0,1:1) K X Q
;OERR ;
;1 S VATAG=1 D MULT Q
;2 S VATAG=2 D MULT Q
;3 S VATAG=3 D MULT Q
;4 S VATAG=4 D MULT Q
;5 S VATAG=5 D MULT Q
;6 S VATAG=6 D MULT Q
;7 S VATAG=7 D MULT Q
;8 S VATAG=8 D MULT Q
;9 S VATAG=9 D MULT Q
;10 S VATAG=10 D MULT Q
;51 S VATAG=11 D MULT Q
;52 S VATAG=12 D MULT Q
;53 S VATAG=13 D MULT Q
;ALL S VATAG=14 D MULT Q
;A5 S VATAG=15 D MULT Q
;SEL Q:$O(VARRAY(0))']"" S VATAG=0,VATAG(2)=$P($T(TAG),";;",2)
;F VATAG(1)=0:0 S VATAG=$O(VARRAY(VATAG)) Q:VATAG="" I VATAG(2)
[("^"_VATAG_"^") S VARRAY(VATAG)=1,VAROOT=$S($D(VAROOT(VATAG)):VAROOT (VATAG),1:"") D @VATAG
;G Q
;
;MULT S VATAG=$P($T(TG+VATAG),";;",2)
;F VATAG(1)=1:1 S VATAG(2)=$P(VATAG,"^",VATAG(1)) Q:VATAG(2)="" S
VAROOT=$S($D(VAROOT(VATAG(2))):VAROOT(VATAG(2)),1:"") D @(VATAG(2))
;Q S VAROOT="" K:$D(VAROOT)'=11 VAROOT K VATAG Q
;
;KVA K VA
;KVAR D KVAR^VADPT0 K:$D(VAIP("V")) @(VAIP("V")) K
I,X,Y,VARRAY,VADM,VAPD,VADPT,VAOA,VASV,VAEL,VAMB,VARP,VAEN,VASD,VAIN,VAIP,VAPA,VAHOW,VAINDT,VAERR,^UTILITY ("VADPT",$J),VA200,VATEST Q
;DATIM(DATIM) ;If time not specified see if movement on that date
;Q:DATIM'?7N DATIM
;N A,B S A=$O(^DGPM("ADFN"_DFN,DATIM)),B=+$O(^(+A,0))
;I 'A Q DATIM
;I $P($G(^DGPM(+B,0)),"^",2)=3 Q DATIM ;Next movement is discharge
;F Q:"^4^5^7^"'[(U_$P($G(^DGPM(+B,0)),"^",2)) S A=$O(^DGPM
("ADFN"_DFN,A)),B=+$O(^(+A,0)) I $E(A,1,7)'=DATIM Q
;I 'A Q DATIM
;I $E(A,1,7)'=DATIM Q DATIM
;Q A
;
;TG ;
;;DEM^INP
;;DEM^ELIG
;;ELIG^INP
;;DEM^ADD
;;ADD^INP
;;DEM^ELIG^ADD
;;ELIG^SVC
;;ELIG^SVC^MB
;;DEM^REG^SDE^SDA
;;SDE^SDA
;;DEM^IN5
;;ELIG^IN5
;;ADD^IN5
;;DEM^OPD^INP^ADD^ELIG^SVC^OAD^MB^REG^SDE^SDA
;;DEM^OPD^IN5^ADD^ELIG^SVC^OAD^MB^REG^SDE^SDA
;
;TAG ;;^DEM^OPD^INP^IN5^ADD^OAD^ELIG^SVC^MB^REG^SDE^SDA^
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; VERY IMPORTANT EXAMPLE OF PATIENT LOOKUP MAIN ROUTINE
;
; DPTLK ;ALB/RMO,RTK - MAS Patient Look-up Main Routine ; 3/22/05
4:19pm
;;
5.3;Registration;**32,72,93,73,136,157,197,232,265,277,223,327,244,513,528,541,576,600,485,633,629,647**;Aug 13, 1993
;
; mods made for magstripe read 12/96 - JFP
;
;Optional input: DPTNOFZY='1' to suppress fuzzy lookups implemented
; by patch DG*5.3*244
;
;
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
DPTLK ;ALB/RMO,RTK - MAS Patient Look-up Main Routine ; 3/22/05 4:19pm
5.3;Registration;**32,72,93,73,136,157,197,232,265,277,223,327,244,513,528,541,576,600,485,633,629,647**;Aug 13, 1993
- mods made for magstripe read 12/96 - JFP
- Optional input
- DPTNOFZY='1' to suppress fuzzy lookups implemented
- by patch DG*5.3*244
EN ; -- Entry point N DIE,DR K DPTX,DPTDFN,DPTSAVX I $D(DIC(0)) G QK:DIC(0)["I"!(DIC(0)'["A"&('$D (X))) I '$D(^DD("VERSION")) W !!?3,"Unable to proceed. Fileman version node ^DD(""VERSION"") is undefined." G QK I '$D(^DPT(0))!(^DD("VERSION")<17.2) W !!?3,"Unable to proceed. ",$S ('$D(^DPT(0)):"0th node of ^DPT missing",^DD("VERSION")<17.2:"Fileman version must be at least 17.2",1:""),"." G QK EN2 K DO,DUOUT,DTOUT S U="^",DIC="^DPT(",DIC(0)=$S($D(DIC(0)):DIC(0), 1:"AELMQ") S:DIC(0)'["A" (DPTX,DPTSAVX)=X S DPTSZ=1000 I $D(^DD("OS"))#2 S DPTSZ=$S(+$P(^DD("OS",^("OS"),0),U,2): $P(^(0),U,2),1:DPTSZ)
ASKPAT ; -- Prompt for patient I DIC(0)["A" D G QK:'$T!($E(DPTX)["^")!(DPTX="") .K DTOUT,DUOUT .W !,$S($D(DIC("A")):DIC("A"),1:"Select PATIENT NAME: ") W:$D(DIC ("B")) DIC("B"),"// " .R X:DTIME .S DPTX=X S:'$T DTOUT=1 S:$T&(DPTX="")&($D(DIC("B"))) DPTX=DIC("B") S:DPTX["^"&($E(DPTX)'="%") DUOUT=1
- -- Check for the IATA magnetic stripe input
N MAG,GCHK S MAG=0 I $E(DPTX)="%"!($E(DPTX)=";"),DPTX["?" S MAG=1,(X,DPTX)=$$IATA(DPTX)
CHKPAT ; -- Custom Patient Lookup D DO^DIC1 S DIC("W")=$S($D(DIC("W")):DIC("W"),1:"") K DPTIFNS,DPTS,DPTSEL S DPTCNT=0
- -- Check input for format an length
G CHKDFN:DPTX?1A!(DPTX'?.ANP)!($L(DPTX)>30)
- -- Check for null response or abort
I DPTX=""!(DPTX["^") G ASKPAT:DIC(0)["A",QK
- -- Check for question mark
I DPTX["?" D G ASKPAT:DIC(0)["A",QK .S D="B" .S DZ=$S(DPTX?1"?":"",1:"??") .G CHKPAT1:DZ="??" .N % .W !,?1,"Answer with PATIENT NAME, or SOCIAL SECURITY NUMBER, or last 4 digits",!,?4,"of SOCIAL SECURITY NUMBER, or first initial of" .W " last name with last",!,?4,"4 digits of SOCIAL SECURITY NUMBER" .W !,?1,"Do you want the entire ",+$P($G(^DPT(0)),"^",4),"-Entry PATIENT List" S %=0 D YN^DICN .Q:%'=1 .S DZ="??" CHKPAT1 .S X=DPTX .D DQ^DICQ
- -- Check for space bar, return
I DPTX=" " D G CHKDFN .S Y=$S('($D(DUZ)#2):-1,$D(^DISV(DUZ,"^DPT(")):^("^DPT("),1:-1) .D SETDPT^DPTLK1:Y>0 .S DPTDFN=$S($D(DPTS(Y)):Y,1:-1)
- -- Check for DFN look up
I $E(DPTX)="`" D G CHKDFN .S Y=$S($D(^DPT(+$P(DPTX,"`",2),0)):+$P(DPTX,"`",2),1:-1) .D SETDPT^DPTLK1:Y>0 .S DPTDFN=$S($D(DPTS(Y)):Y,1:-1)
- -- Puts input in correct format
G CHKDFN:DPTX=""
- -- Force new entry
I $E(DPTX)="""",$E(DPTX,$L(DPTX))="""" G NOPAT
- -- Check for index lookups
D ^DPTLK1 G QK:$D(DTOUT)!($D(DUOUT)&(DIC(0)'["A")),ASKPAT:$D (DUOUT),CHKPAT:DPTDFN<0,CHKDFN:DPTDFN>0 I DIC(0)["N",$D(^DPT(DPTX,0)) S Y=X D SETDPT^DPTLK1 S DPTDFN=$S($D(DPTS(Y)):Y,1:-1) G CHKDFN MAG ; -- No patient found, check for mag stripe input, create stub I 'MAG G NOPAT
- -- Check for ADT option(s) only
N DGOPT S DGOPT=$P($G(XQY0),"^",2) I DGOPT'="Load/Edit Patient Data",DGOPT'="Register a Patient" D G EN2 .W !," ...Patient not in database, use ADT options to load patient" D Q1
- -- Prompt for creation of stub
S DIR(0)="Y",DIR("B")="NO",DIR("A")="Patient not found...Create stub entry: " S GCHK=$D(^TMP("DGVIC")) D ^DIR K DIR I 'Y D Q1 G EN2
- -- Parse IATA fields
D FIELDS(IATA)
- -- Check for Duplicates
D EP2^DPTLK3 I DPTDFN<0 D Q1 G EN2
- -- Creates Stub entry in patient file
S Y=$$FILE^DPTLK4(DGFLDS) I $P(Y,"^",3)'=1 W !,"Could not add patient to patient file" D QK1 Q D QK1 Q
NOPAT ; -- No patient found, ask to add new I DIC(0)["L" D ^DPTLK2 S Y=DPTDFN G ASKPAT:DIC(0)["A"&(Y<0)&('$G (DTOUT)),QK1
CHKDFN ; -- S:'$D(DPTDFN) DPTDFN=-1 I DPTDFN'>0!('$D(DPTS(+DPTDFN))) W:DIC(0)["Q"
- 7," ??" G ASKPAT:DIC(0)["A",QK
I DIC(0)["E" D W $S('$D(DPTSEL)&('$D(DIVP)):$P(DPTS(DPTDFN),U,2)_" "_$P (DPTS(DPTDFN),U)_" ",$D(^DPT(DPTDFN,0)):" "_$P(^(0),U)_" ",1:"") S Y=DPTDFN X:$D(^DPT(DPTDFN,0)) "N DDS X DIC(""W"")" .I $D(DDS) D CLRMSG^DDS S DX=0,DY=DDSHBX+1 X DDXY
- check for other patients in "BS5" xref on Patient file
I '$G(DICR),DPTDFN>0,DIC(0)["E",$$BS5^DPTLK5(+DPTDFN) D G ASKPAT:DIC(0) ["A"&(%'=1),QK:DPTDFN<0 .N DPTZERO,DPTLSNME,DPTSSN S DPTZERO=$G(^DPT(+DPTDFN,0)),DPTLSNME=$P($P (DPTZERO,U),","),DPTSSN=$E($P(DPTZERO,U,9),6,9) .W $C(7),!!,"There is more than one patient whose last name is '",DPTLSNME,"' and" .W !,"whose social security number ends with '",DPTSSN,"'." .W !,"Are you sure you wish to continue (Y/N)" S %=0 D YN^DICN .I %'=1 S DPTDFN=-1
I '$G(DICR),DPTDFN>0 S Y=DPTDFN D ^DGSEC S DPTDFN=Y G ASKPAT:DIC(0) ["A"&(DPTDFN<0),QK:DPTDFN<0 S DPTX=DPTX_$P(DPTS(DPTDFN),U,2),DPTDFN=DPTDFN_U_$P(^DPT(DPTDFN,0),U)
Q ; -- S Y=$S('$D(DPTDFN):-1,'$D(DPTS(+DPTDFN)):-1,1:DPTDFN),X=$S($D(DPTX)& (+Y>0):DPTX,$D(DPTSAVX):DPTSAVX,$D(DPTX):DPTX,1:"") I Y>0 S:DIC(0)'["F" ^DISV($S($D(DUZ)#2:DUZ,1:0),"^DPT(")=+Y S:DIC(0) ["Z" Y(0)=^DPT(+Y,0),Y(0,0)=$P(^(0),U,1)
- DG*600
- I DIC(0)["E",$P($G(^DPT(+Y,0)),U,21) W *7,!,"Warning
- You have
selected a test patient." I DIC(0)["E",$$TESTPAT^VADPT(+Y) W *7,!,"WARNING : You may have selected a test patient." I DIC(0)["E",$$BADADR^DGUTL3(+Y) W *7,!,"WARNING : ** This patient has been flagged with a Bad Address Indicator." I DIC(0)["E",$$VAADV^DPTLK3(+Y) W *7,!,"** Patient is VA ADVANTAGE."
- DG*485
I $D(^DPT("AXFFP",1,+Y)) D FFP^DPTLK5
- Display enrollment information
I Y>0,DIC(0)["E" D ENR
- Call Combat Vet check
I Y>0,DIC(0)["E" D CV
- check whether to display Means Test Required message
D .N DPTDIV .I '$G(DUZ(2)) Q .I Y>0,DIC(0)["E" S DPTDIV=$$DMT^DPTLK5(+Y,DUZ(2)) I DPTDIV D ..W $C(7),!!,"MEANS TEST REQUIRED" ..W !,?3,$P($G(^DG(40.8,DPTDIV,"MT")),U,2) ..H 2
Q1 ; -- Clean up variables K D,DIC("W"),DO,DPTCNT,DPTDFN,DPTIFNS,DPTIX,DPTS K DPTSAVX,DPTSEL,DPTSZ,DPTX
K:$D(IATA) IATA K:$D(DGFLDS) @DGFLDS,DGFLDS Q
QK K:'$D(DPTNOFZK) DPTNOFZY G Q
QK1 K:'$D(DPTNOFZK) DPTNOFZY G Q1
IX ; -- I $D(D),$D(^DD(2,0,"IX",D)),($E(D)'="A") S DPTIX=D G DPTLK
IATA(X) ; --
- This function pulls off ssn from the IATA track
- Input
- X - what was read in
- Output
- SSN - social security number
- Q - quit
- Track Start Sent End Sent Field Separator
- ----- ---------- -------- ---------------
- IATA (alphanum) % ? { (Note
- VA used ^)
- ABA (numeric) ; ? =
- N IATA
S (IATA)="" I $E(X)'="%" Q X ; no start sentinel I X'["?" Q "Q"
- -- Extract data from track
S IATA=$$TRACK(X,"%","?")
- -- checks for no data
I IATA="" Q "Q"
- -- Returns SSN
I IATA'="" Q $P(IATA,"^") Q "Q"
TRACK(X,START,END) ; find track where start/end are sentinels
Q $P($P($G(X),START,2),END,1)
FIELDS(IATA) ; -- Sets fields Q:'$D(IATA) N CNT,FIELD S DGFLDS="^TMP(""DGVIC"","_$J_")",CNT=1 K @DGFLDS F S FIELD=$P($G(IATA),"^",CNT) Q:FIELD="" D .S @DGFLDS@(CNT)=FIELD .S CNT=CNT+1
- -- Define fields for duplicate checker
S DPTX=$G(@DGFLDS@(2)) ;NAME S DPTIDS(.03)=$G(@DGFLDS@(3)) ;DOB S DPTIDS(.09)=$G(@DGFLDS@(1)) ;SSN Q ENR ;Display Enrollment information after patient selection N DGENCAT,DGENDFN,DGENR,DGEGTIEN,DGEGT I '$$GET^DGENA($$FINDCUR^DGENA(+DPTDFN),.DGENR) Q S DGENCAT=$$CATEGORY^DGENA4(+DPTDFN) S DGENCAT=$$EXTERNAL^DILFD(27.15,.02,"",DGENCAT) W !?1,"Enrollment Priority: ",$S($G(DGENR("PRIORITY")):$$EXT^DGENU ("PRIORITY",DGENR("PRIORITY")),1:""),$S($G(DGENR("SUBGRP"))="":"",1:$ $EXT^DGENU("SUBGRP",$G(DGENR("SUBGRP")))) W ?33,"Category: ",DGENCAT W ?57,"End Date: ",$S($G(DGENR("END")):$$FMTE^XLFDT(DGENR ("END"),"5DZ"),1:""),!
- If patient is NOT ELIGIBLE, display Enrollment Status (Ineligible
Project Phase I) I $G(DGENR("STATUS"))=10!($G(DGENR("STATUS"))=19)!($G(DGENR("STATUS")) =20) D . W ?1,"Enrollment Status: ",$S($G(DGENR("STATUS")):$$EXT^DGENU ("STATUS",DGENR("STATUS")),1:"") ;H 5
- check for Combat Veteran Eligibility, if elig do not display EGT info
I $$CVEDT^DGCV(+DPTDFN) Q
- Get Enrollment Group Threshold Priority and Subgroup
S DGEGTIEN=$$FINDCUR^DGENEGT S DGEGT=$$GET^DGENEGT(DGEGTIEN,.DGEGT) Q:$G(DGENR("PRIORITY"))=""!($G(DGEGT("PRIORITY"))="")
- Compare Patient's Enrollment Priority to Enrollment Group Threshold
I '$$ABOVE^DGENEGT1(+DPTDFN,DGENR("PRIORITY"),$G(DGENR("SUBGRP")),DGEGT ("PRIORITY"),DGEGT("SUBGRP")) D .N X,IORVOFF,IORVON .S X="IORVOFF;IORVON" .D ENDR^%ZISS .W !?32 W:$D(IORVON) IORVON W "*** WARNING ***" W:$D(IORVOFF) IORVOFF .I DGENR("END")'="" W !?14 W:$D(IORVON) IORVON W "*** PATIENT ENROLLMENT END",$S(DT>+DGENR("END"):"ED",1:"S")," EFFECTIVE ",$ $FMTE^XLFDT(DGENR("END"),"5DZ")," ***" W:$D(IORVOFF) IORVOFF Q .W !?5 W:$D(IORVON) IORVON W "*** PATIENT ENROLLMENT ENDING. ENROLLMENT END DATE IS NOT KNOWN. ***" W:$D(IORVOFF) IORVOFF Q CV ;check for Combat Vet status N DGCV S DGCV=$$CVEDT^DGCV(+DPTDFN) I $P(DGCV,U)=1 D Q . I '$$GET^DGENA($$FINDCUR^DGENA(+DPTDFN),.DGENR) W ! . W ?3,"Combat Vet Status: "_$S($P(DGCV,U,3)=1:"ELIGIBLE", 1:"EXPIRED"),?57,"End Date: "_$$FMTE^XLFDT($P(DGCV,U,2),"5DZ")
