AUPNLK ; IHS/CMI/LAB - IHS PATIENT LOOKUP MAIN ROUTINE 24-MAY-1993 ; [ 03/16/2004 7:43 AM ]
;;99.1;IHS DICTIONARIES (PATIENT);**5,6,9,10,12,13**;JUN 13, 2003;Build 9
;patch 5 - fm v22
;'Modified' MAS Patient Look-up Routine for ADT Version 3.6, June 1987
; This routine will not be executed if DIC(0)["I" or caller
; used IX^DIC.
;
; AUPQF values have the following meaning:
; 0 = Initial state
; 1 = Primary error
; 2 = Operator/time out
; 3 = Retry
; 4 = Hit
; 5 = Added patient
;;EP;ENTERNAL ENTRY POINT
;
START ;
D ^AUPNLKI ; Initialization
I AUPQF D EOJ Q
D FINDPAT ; Find patient
D EOJ ; Cleanup
S:'$D(X) X=""
Q
;
FINDPAT ; FIND PATIENT
I DIC(0)'["A" S AUPX=X D CHKPAT D:AUPQF=4 HIT Q
F AUPL=0:0 S AUPQF=0 D ASKPAT D CHKPAT D:AUPQF=4 HIT Q:AUPQF'=3
Q
;
ASKPAT ;
K AUPCNT,AUPD,AUPIDS,AUPIFN,AUPIFNS,AUPNDAYS,AUPNDOB,AUPNDOD,AUPNICK,AUPNPAT,AUPNSEX,AUPNUM,AUPS,AUPSEL,DTOUT,DUOUT ; IHS/SD/EFG AUPN*99.1*13 3/16/2004
;N AUP,AUPBEG,AUPCNT,AUPDFN,AUPDIC,AUPDICS,AUPDICW,AUPI,AUPIFN,AUPIFNS,AUPIX,AUPL,AUPNICK,AUPNUM,AUPQF,AUPS,AUPSEL,AUPLP1,AUPMAPY ; IHS/SD/EFG AUPN*99.1*13 3/16/2004
S AUPX=""
;W !!,$S($D(DIC("A")):DIC("A"),1:"Select PATIENT NAME: ") I $D(DIC("B")),DIC("B")]"" W DIC("B"),"// " S AUPX=DIC("B")
;D EN^DDIOL($S($D(DIC("A")):DIC("A"),1:"Select PATIENT NAME: "),"","!!") I $D(DIC("B")),DIC("B")]"" D EN^DDIOL(DIC("B")_"// ") S AUPX=DIC("B")
NEW DSPVAL S DSPVAL=$S($D(DIC("A")):DIC("A"),1:"Select PATIENT NAME: ")
I $D(DIC("B")),DIC("B")]"" S AUPX=DIC("B"),DSPVAL=DSPVAL_DIC("B")_"//"
D EN^DDIOL(DSPVAL)
R X:DTIME S:X["^" DUOUT=1 S:'$T DTOUT=1,X="^"
S:X]"" AUPX=X
Q
;
CHKPAT ;
K AUPIFNS,AUPS,AUPSEL
S AUPCNT=0
I AUPX=""!(AUPX["^") S AUPQF=2 Q
I AUPX["?" D ^AUPNLKH S AUPQF=3 Q
;I AUPX?1A!(AUPX'?.ANP)!($L(AUPX)>30)!($E(AUPX)=",") W:DIC(0)["Q" *7," ??" S AUPQF=3 Q
I AUPX?1A!(AUPX'?.ANP)!($L(AUPX)>30)!($E(AUPX)=",") D:DIC(0)["Q" S AUPQF=3 Q
.NEW % S %=$C(7)_" ??" D EN^DDIOL(%)
I '$D(DIADD),AUPX'?1"""".E1"""" D LOOKUPS^AUPNLKB ; Find patient
Q:AUPQF ; Quit if patient found
I DIC(0)["L" D ADDPAT^AUPNLKB ; Try adding the patient
Q:AUPQF ; Quit if add successful
;W:DIC(0)["Q" *7," ??"
I DIC(0)["Q" D EN^DDIOL($C(7)_" ??")
S AUPQF=3
Q
;
HIT ;
I DIC(0)["E" D WRT
Q:AUPQF'=4
I '$D(DICR),$T(SENS^DGSEC4)]"" S Y=+AUPDFN D ^DGSEC S AUPDFN=Y I Y<0 S AUPQF=3 Q ;IHS/ANMC/LJF 9/1/2000
S AUPX=$P(AUPS(AUPDFN),U,2),AUPDFN=AUPDFN_U_$P(AUPS(AUPDFN),U)
N DA,X S DA=+AUPDFN X $P(^DD(2,.081,0),U,5,99) I X,DIC(0)["E" D DUPECHK
Q
;
WRT ;
I $P(@(AUPDIC_"0)"),U,2)["O"!('$D(AUPSEL)&($D(AUPNICK(AUPDFN)))) D WRT2
Q:AUPQF'=4
I '$D(AUPSEL),'$D(AUPNICK(AUPDFN)),$P($P(AUPS(AUPDFN),U,2),AUPX)="" D EN^DDIOL($E($P(AUPS(AUPDFN),U,2),$L(AUPX)+1,$L($P(AUPS(AUPDFN),U,2))))
D EN^DDIOL($S($D(AUPSEL)!($P(AUPS(AUPDFN),U)'=$P(AUPS(AUPDFN),U,2)):" "_$P(AUPS(AUPDFN),U)_" ",1:" "))
S Y=+AUPDFN X:$D(^DPT(AUPDFN,0)) DIC("W")
Q
;
WRT2 ;
D EN^DDIOL(" "_$P(^DPT(AUPDFN,0),U)),EN^DDIOL("OK","","!?8")
S %=1 D YN^DICN
S:%'=1 AUPQF=3,AUPDFN=-1
K %,%Y
Q
;
DUPECHK ; SELECTED PATIENT HAS UNRESOLVED DUPES
I $D(^VA(15,"ALK","DPT(",+Y,2)) S AUPMT=$O(^(2,0)) D DUPECHK2 Q
; Code to inform user of potential duplicates would go here.
Q
;
DUPECHK2 ; VERIFIED DUPE
D EN^DDIOL("The patient you have selected is a 'verified duplicate' of","","!?6")
D EN^DDIOL($P(^DPT(AUPMT,0),U),"","!?12") S AUPSY=Y,Y=AUPMT D SET^AUPNLKZ X DIC("W") S Y=AUPSY D RESET^AUPNLKZ
D EN^DDIOL("If you are adding data for this patient please reselect!","","!?6")
K AUPMT,AUPSY
Q
;
EOJ ;
K AUPNLK("ICN")
I AUPQF=1 S Y=-1 K AUPQF,AUPDIC,DIC("W") Q
I AUPQF=2!(AUPQF=3) S Y=-1,X=AUPX D KILL Q
S Y=AUPDFN,X=AUPX
D EOJ2
D KILL
Q
;
EOJ2 ;
; - FOLLOW MERGE CHAIN -
S AUPSY=Y
F AUPL=0:0 Q:'$P(^DPT(+Y,0),U,19) S Y=$P(^(0),U,19),Y=Y_U_$P(^DPT(Y,0),U,1) ; Will abort if no ^DPT entry for Y
I DIC(0)["E",Y'=AUPSY D EN^DDIOL("You now have patient "_$P(^DPT(+Y,0),U),"","!?6")
K AUPSY
; -- SPACE BAR AND Y(0) --
S:DIC(0)'["F" ^DISV($S($D(DUZ)#2:DUZ,1:0),"^DPT(")=+Y,^DISV($S($D(DUZ)#2:DUZ,1:0),"^AUPNPAT(")=+Y S:DIC(0)["Z" Y(0)=^DPT(+Y,0),Y(0,0)=$P(^(0),U,1)
; -- RESET Y AND Y(0) FOR 9000001 LOOKUP --
I AUPDIC="^AUPNPAT(" S $P(Y,U,2)=+Y I DIC(0)["Z" S Y(0)=^AUPNPAT(+Y,0)
; -- POST SELECTION --
X:$D(^DD(2,0,"ACT")) ^("ACT") X:$D(^DD(9000001,0,"ACT")) ^("ACT")
; -- SET NAKED --
S:$D(AUPDIC) DIC=AUPDIC I $D(@(DIC_"+Y,0)"))
; ----- -
Q
;
KILL ;
; - RESTORE DIC AND DIC("S") -
S:$D(AUPDIC) DIC=AUPDIC
;K DIC("S","IHSORIG"),DIC("S","IHSLOOK") K:$D(DIC("S"))<10 DIC("S") S:$D(AUPDICS) DIC("S")=AUPDICS
K AUPNORIG,AUPNLOOK K:$D(DIC("S"))<10 DIC("S") S:$D(AUPDICS) DIC("S")=AUPDICS ;IHS/ANMC/CLS 09/13/2000 fm v22
; - - -
K D,DIC("W"),DO
D:$D(AUPNLK("ALL")) RESET^AUPNLKZ ; Undocumented feature
S AUPX=$S($D(AUPNLK("ALL")):1,1:0) K AUPNLK S:AUPX AUPNLK("ALL")=1
K AUP,AUPBEG,AUPCNT,AUPDFN,AUPDIC,AUPDICS,AUPDICW,AUPI,AUPIFN,AUPIFNS,AUPIX,AUPL,AUPNICK,AUPNUM,AUPQF,AUPS,AUPSEL,AUPX,AUPLP1,AUPMAPY ; IHS/SD/EFG AUPN*99.1*13 3/16/2004
Q
AUPNLK ; IHS/CMI/LAB - IHS PATIENT LOOKUP MAIN ROUTINE 24-MAY-1993 ; [ 03/16/2004 7:43 AM ]
+1 ;;99.1;IHS DICTIONARIES (PATIENT);**5,6,9,10,12,13**;JUN 13, 2003;Build 9
+2 ;patch 5 - fm v22
+3 ;'Modified' MAS Patient Look-up Routine for ADT Version 3.6, June 1987
+4 ; This routine will not be executed if DIC(0)["I" or caller
+5 ; used IX^DIC.
+6 ;
+7 ; AUPQF values have the following meaning:
+8 ; 0 = Initial state
+9 ; 1 = Primary error
+10 ; 2 = Operator/time out
+11 ; 3 = Retry
+12 ; 4 = Hit
+13 ; 5 = Added patient
+14 ;;EP;ENTERNAL ENTRY POINT
+15 ;
START ;
+1 ; Initialization
DO ^AUPNLKI
+2 IF AUPQF
DO EOJ
QUIT
+3 ; Find patient
DO FINDPAT
+4 ; Cleanup
DO EOJ
+5 IF '$DATA(X)
SET X=""
+6 QUIT
+7 ;
FINDPAT ; FIND PATIENT
+1 IF DIC(0)'["A"
SET AUPX=X
DO CHKPAT
IF AUPQF=4
DO HIT
QUIT
+2 FOR AUPL=0:0
SET AUPQF=0
DO ASKPAT
DO CHKPAT
IF AUPQF=4
DO HIT
IF AUPQF'=3
QUIT
+3 QUIT
+4 ;
ASKPAT ;
+1 ; IHS/SD/EFG AUPN*99.1*13 3/16/2004
KILL AUPCNT,AUPD,AUPIDS,AUPIFN,AUPIFNS,AUPNDAYS,AUPNDOB,AUPNDOD,AUPNICK,AUPNPAT,AUPNSEX,AUPNUM,AUPS,AUPSEL,DTOUT,DUOUT
+2 ;N AUP,AUPBEG,AUPCNT,AUPDFN,AUPDIC,AUPDICS,AUPDICW,AUPI,AUPIFN,AUPIFNS,AUPIX,AUPL,AUPNICK,AUPNUM,AUPQF,AUPS,AUPSEL,AUPLP1,AUPMAPY ; IHS/SD/EFG AUPN*99.1*13 3/16/2004
+3 SET AUPX=""
+4 ;W !!,$S($D(DIC("A")):DIC("A"),1:"Select PATIENT NAME: ") I $D(DIC("B")),DIC("B")]"" W DIC("B"),"// " S AUPX=DIC("B")
+5 ;D EN^DDIOL($S($D(DIC("A")):DIC("A"),1:"Select PATIENT NAME: "),"","!!") I $D(DIC("B")),DIC("B")]"" D EN^DDIOL(DIC("B")_"// ") S AUPX=DIC("B")
+6 NEW DSPVAL
SET DSPVAL=$SELECT($DATA(DIC("A")):DIC("A"),1:"Select PATIENT NAME: ")
+7 IF $DATA(DIC("B"))
IF DIC("B")]""
SET AUPX=DIC("B")
SET DSPVAL=DSPVAL_DIC("B")_"//"
+8 DO EN^DDIOL(DSPVAL)
+9 READ X:DTIME
IF X["^"
SET DUOUT=1
IF '$TEST
SET DTOUT=1
SET X="^"
+10 IF X]""
SET AUPX=X
+11 QUIT
+12 ;
CHKPAT ;
+1 KILL AUPIFNS,AUPS,AUPSEL
+2 SET AUPCNT=0
+3 IF AUPX=""!(AUPX["^")
SET AUPQF=2
QUIT
+4 IF AUPX["?"
DO ^AUPNLKH
SET AUPQF=3
QUIT
+5 ;I AUPX?1A!(AUPX'?.ANP)!($L(AUPX)>30)!($E(AUPX)=",") W:DIC(0)["Q" *7," ??" S AUPQF=3 Q
+6 IF AUPX?1A!(AUPX'?.ANP)!($LENGTH(AUPX)>30)!($EXTRACT(AUPX)=",")
IF DIC(0)["Q"
Begin DoDot:1
+7 NEW %
SET %=$CHAR(7)_" ??"
DO EN^DDIOL(%)
End DoDot:1
SET AUPQF=3
QUIT
+8 ; Find patient
IF '$DATA(DIADD)
IF AUPX'?1"""".E1""""
DO LOOKUPS^AUPNLKB
+9 ; Quit if patient found
IF AUPQF
QUIT
+10 ; Try adding the patient
IF DIC(0)["L"
DO ADDPAT^AUPNLKB
+11 ; Quit if add successful
IF AUPQF
QUIT
+12 ;W:DIC(0)["Q" *7," ??"
+13 IF DIC(0)["Q"
DO EN^DDIOL($CHAR(7)_" ??")
+14 SET AUPQF=3
+15 QUIT
+16 ;
HIT ;
+1 IF DIC(0)["E"
DO WRT
+2 IF AUPQF'=4
QUIT
+3 ;IHS/ANMC/LJF 9/1/2000
IF '$DATA(DICR)
IF $TEXT(SENS^DGSEC4)]""
SET Y=+AUPDFN
DO ^DGSEC
SET AUPDFN=Y
IF Y<0
SET AUPQF=3
QUIT
+4 SET AUPX=$PIECE(AUPS(AUPDFN),U,2)
SET AUPDFN=AUPDFN_U_$PIECE(AUPS(AUPDFN),U)
+5 NEW DA,X
SET DA=+AUPDFN
XECUTE $PIECE(^DD(2,.081,0),U,5,99)
IF X
IF DIC(0)["E"
DO DUPECHK
+6 QUIT
+7 ;
WRT ;
+1 IF $PIECE(@(AUPDIC_"0)"),U,2)["O"!('$DATA(AUPSEL)&($DATA(AUPNICK(AUPDFN))))
DO WRT2
+2 IF AUPQF'=4
QUIT
+3 IF '$DATA(AUPSEL)
IF '$DATA(AUPNICK(AUPDFN))
IF $PIECE($PIECE(AUPS(AUPDFN),U,2),AUPX)=""
DO EN^DDIOL($EXTRACT($PIECE(AUPS(AUPDFN),U,2),$LENGTH(AUPX)+1,$LENGTH($PIECE(AUPS(AUPDFN),U,2))))
+4 DO EN^DDIOL($SELECT($DATA(AUPSEL)!($PIECE(AUPS(AUPDFN),U)'=$PIECE(AUPS(AUPDFN),U,2)):" "_$PIECE(AUPS(AUPDFN),U)_" ",1:" "))
+5 SET Y=+AUPDFN
IF $DATA(^DPT(AUPDFN,0))
XECUTE DIC("W")
+6 QUIT
+7 ;
WRT2 ;
+1 DO EN^DDIOL(" "_$PIECE(^DPT(AUPDFN,0),U))
DO EN^DDIOL("OK","","!?8")
+2 SET %=1
DO YN^DICN
+3 IF %'=1
SET AUPQF=3
SET AUPDFN=-1
+4 KILL %,%Y
+5 QUIT
+6 ;
DUPECHK ; SELECTED PATIENT HAS UNRESOLVED DUPES
+1 IF $DATA(^VA(15,"ALK","DPT(",+Y,2))
SET AUPMT=$ORDER(^(2,0))
DO DUPECHK2
QUIT
+2 ; Code to inform user of potential duplicates would go here.
+3 QUIT
+4 ;
DUPECHK2 ; VERIFIED DUPE
+1 DO EN^DDIOL("The patient you have selected is a 'verified duplicate' of","","!?6")
+2 DO EN^DDIOL($PIECE(^DPT(AUPMT,0),U),"","!?12")
SET AUPSY=Y
SET Y=AUPMT
DO SET^AUPNLKZ
XECUTE DIC("W")
SET Y=AUPSY
DO RESET^AUPNLKZ
+3 DO EN^DDIOL("If you are adding data for this patient please reselect!","","!?6")
+4 KILL AUPMT,AUPSY
+5 QUIT
+6 ;
EOJ ;
+1 KILL AUPNLK("ICN")
+2 IF AUPQF=1
SET Y=-1
KILL AUPQF,AUPDIC,DIC("W")
QUIT
+3 IF AUPQF=2!(AUPQF=3)
SET Y=-1
SET X=AUPX
DO KILL
QUIT
+4 SET Y=AUPDFN
SET X=AUPX
+5 DO EOJ2
+6 DO KILL
+7 QUIT
+8 ;
EOJ2 ;
+1 ; - FOLLOW MERGE CHAIN -
+2 SET AUPSY=Y
+3 ; Will abort if no ^DPT entry for Y
FOR AUPL=0:0
IF '$PIECE(^DPT(+Y,0),U,19)
QUIT
SET Y=$PIECE(^(0),U,19)
SET Y=Y_U_$PIECE(^DPT(Y,0),U,1)
+4 IF DIC(0)["E"
IF Y'=AUPSY
DO EN^DDIOL("You now have patient "_$PIECE(^DPT(+Y,0),U),"","!?6")
+5 KILL AUPSY
+6 ; -- SPACE BAR AND Y(0) --
+7 IF DIC(0)'["F"
SET ^DISV($SELECT($DATA(DUZ)#2:DUZ,1:0),"^DPT(")=+Y
SET ^DISV($SELECT($DATA(DUZ)#2:DUZ,1:0),"^AUPNPAT(")=+Y
IF DIC(0)["Z"
SET Y(0)=^DPT(+Y,0)
SET Y(0,0)=$PIECE(^(0),U,1)
+8 ; -- RESET Y AND Y(0) FOR 9000001 LOOKUP --
+9 IF AUPDIC="^AUPNPAT("
SET $PIECE(Y,U,2)=+Y
IF DIC(0)["Z"
SET Y(0)=^AUPNPAT(+Y,0)
+10 ; -- POST SELECTION --
+11 IF $DATA(^DD(2,0,"ACT"))
XECUTE ^("ACT")
IF $DATA(^DD(9000001,0,"ACT"))
XECUTE ^("ACT")
+12 ; -- SET NAKED --
+13 IF $DATA(AUPDIC)
SET DIC=AUPDIC
IF $DATA(@(DIC_"+Y,0)"))
+14 ; ----- -
+15 QUIT
+16 ;
KILL ;
+1 ; - RESTORE DIC AND DIC("S") -
+2 IF $DATA(AUPDIC)
SET DIC=AUPDIC
+3 ;K DIC("S","IHSORIG"),DIC("S","IHSLOOK") K:$D(DIC("S"))<10 DIC("S") S:$D(AUPDICS) DIC("S")=AUPDICS
+4 ;IHS/ANMC/CLS 09/13/2000 fm v22
KILL AUPNORIG,AUPNLOOK
IF $DATA(DIC("S"))<10
KILL DIC("S")
IF $DATA(AUPDICS)
SET DIC("S")=AUPDICS
+5 ; - - -
+6 KILL D,DIC("W"),DO
+7 ; Undocumented feature
IF $DATA(AUPNLK("ALL"))
DO RESET^AUPNLKZ
+8 SET AUPX=$SELECT($DATA(AUPNLK("ALL")):1,1:0)
KILL AUPNLK
IF AUPX
SET AUPNLK("ALL")=1
+9 ; IHS/SD/EFG AUPN*99.1*13 3/16/2004
KILL AUP,AUPBEG,AUPCNT,AUPDFN,AUPDIC,AUPDICS,AUPDICW,AUPI,AUPIFN,AUPIFNS,AUPIX,AUPL,AUPNICK,AUPNUM,AUPQF,AUPS,AUPSEL,AUPX,AUPLP1,AUPMAPY
+10 QUIT
