AUPNLK2 ; IHS/CMI/LAB - IHS PATIENT LOOKUP ADD NEW PATIENT ; [ 11/02/2006 9:48 AM ]
;;99.1;IHS DICTIONARIES (PATIENT);**14,15,17**;MAR 09, 1999;Build 9
;'Modified' MAS Patient Look-up Add New Patient, June 1987
;
; Upon exiting this routine AUPDFN will be set as follows:
;
; AUPDFN >0 means patient added and AUPDFN is the DFN
; AUPDFN <0 means patient not added
;
; AUPQF2 values have the following meaning:
;
; 0 = Initial state
; 1 = Primary error
; 2 = Name edit error
; 3 = Operator said no
; 4 = Identifier failure
; 5 = No add from dupe checker
; 6 = Add failed
;
START ;
D INIT ; Initialization
I AUPQF2 D EOJ Q
D EDIT ; Edit the name
I AUPQF2 D EOJ Q
K AUPLID
I DIC(0)["E" D TALK ; Ask if add, get identifiers, check dupes
I AUPQF2 D EOJ Q
D ADDPAT ; Add patient
I AUPQF2 D EOJ Q
D EOJ
Q
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
EDIT ; EXTERNAL ENTRY POINT - EDIT NAME
S X=AUPX
X $P(^DD(2,.01,0),U,5,99)
I '$D(X) S AUPQF2=2 W:DIC(0)["Q" *7," ??" Q
;IHS/ITSC/WAR 6/25/2004 Set AUPX = X if changed
I X'=AUPX S AUPX=X
Q
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
TALK ; EXTERNAL ENTERY POINT - TALK TO OPERATOR
D ^AUPNLK2B
Q
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
ADDPAT ; ADD PATIENT
I $D(AUPLID),DIC(0)["E" W !!?3,"Please enter the following additional information:",!?3
K DD,DO S X=AUPX S:$D(AUP("DR")) DIC("DR")=AUP("DR") D FILE^DICN S DIC("W")=AUPDICW K:$D(AUP("DR")) DIC("DR") S AUPDFN=Y
I +AUPDFN>0 L +^DPT(+AUPDFN):10 D IHSPAT L
Q
;
IHSPAT ; ADD PATIENT TO 9000001
K DD,DO
F AUPV="DINUM","DIC","DIC(""DR"")","DIC(0)","DLAYGO" S:$D(@AUPV) AUPRCR(AUPV)=@AUPV
S X=+AUPDFN,DINUM=X,DIC="^AUPNPAT(",DIC(0)="L",DLAYGO=9000001,DIC("DR")=".02////"_DT_";.11////"_DUZ D FILE^DICN L +^DPT(+AUPDFN):10 S DIC("W")=AUPDICW I Y<0 D IHSPATE
K DINUM,DIC("DR"),DIC(0),DLAYGO S AUPV="" F AUPL=0:0 S AUPV=$O(AUPRCR(AUPV)) Q:AUPV="" S @AUPV=AUPRCR(AUPV)
K AUPRCR,AUPV
Q
;
IHSPATE ; ERROR ADDING TO 9000001
W:AUPRCR("DIC(0)")["Q" !!?3,"Adding patient to ^AUPNPAT failed. Patient being removed from ^DPT also.",!
S DA=+AUPDFN,DIK="^DPT(" D ^DIK K DA,DIK
S AUPQF2=6
Q
;
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
INIT ; EXTERNAL ENTERY POINT - INITIALIZATION
S AUPQF2=0
I '$D(DUZ(0)) W:DIC(0)["Q" !?3,*7,"Unable to Add Patient. Your Fileman Access Code is undefined." S AUPQF2=1 Q
D ACCESS K I,X
Q:AUPQF2
S:'($D(DUZ)#2) DUZ=0 S:DUZ="" DUZ=0
;AUPN*99.1*15, line below used to reference ^DIC(3
I '$D(^VA(200,DUZ)) W:DIC(0)["Q" !?3,*7,"Unable to Add Patient. DUZ is not a valid user." S AUPQF2=1 Q
Q
;
ACCESS ; CHECK FILEMAN ACCESS
S X=$S(AUPDIC="^DPT(":2,1:9000001)
I $S($D(DLAYGO):X-DLAYGO,1:1),DUZ(0)'["@",$D(^DIC(X,0,"LAYGO")) S X=^("LAYGO") X "F I=1:1 I DUZ(0)[$E(X,I) Q" I I>$L(DUZ(0)) W:DIC(0)["Q" !?3,*7,"Unable to Add Patient. You do not have Add authority." S AUPQF2=1 Q
Q
;
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
EOJ ; EXTERNAL ENTRY POINT
S:AUPQF2 AUPDFN=-1
K AUPGID,AUPID,AUPID0,AUPIDS,AUPLID,AUP("DR"),AUPQF2,AUPRCR,AUPSET,AUPV
Q
AUPNLK2 ; IHS/CMI/LAB - IHS PATIENT LOOKUP ADD NEW PATIENT ; [ 11/02/2006 9:48 AM ]
+1 ;;99.1;IHS DICTIONARIES (PATIENT);**14,15,17**;MAR 09, 1999;Build 9
+2 ;'Modified' MAS Patient Look-up Add New Patient, June 1987
+3 ;
+4 ; Upon exiting this routine AUPDFN will be set as follows:
+5 ;
+6 ; AUPDFN >0 means patient added and AUPDFN is the DFN
+7 ; AUPDFN <0 means patient not added
+8 ;
+9 ; AUPQF2 values have the following meaning:
+10 ;
+11 ; 0 = Initial state
+12 ; 1 = Primary error
+13 ; 2 = Name edit error
+14 ; 3 = Operator said no
+15 ; 4 = Identifier failure
+16 ; 5 = No add from dupe checker
+17 ; 6 = Add failed
+18 ;
START ;
+1 ; Initialization
DO INIT
+2 IF AUPQF2
DO EOJ
QUIT
+3 ; Edit the name
DO EDIT
+4 IF AUPQF2
DO EOJ
QUIT
+5 KILL AUPLID
+6 ; Ask if add, get identifiers, check dupes
IF DIC(0)["E"
DO TALK
+7 IF AUPQF2
DO EOJ
QUIT
+8 ; Add patient
DO ADDPAT
+9 IF AUPQF2
DO EOJ
QUIT
+10 DO EOJ
+11 QUIT
+12 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+13 ;
EDIT ; EXTERNAL ENTRY POINT - EDIT NAME
+1 SET X=AUPX
+2 XECUTE $PIECE(^DD(2,.01,0),U,5,99)
+3 IF '$DATA(X)
SET AUPQF2=2
IF DIC(0)["Q"
WRITE *7," ??"
QUIT
+4 ;IHS/ITSC/WAR 6/25/2004 Set AUPX = X if changed
+5 IF X'=AUPX
SET AUPX=X
+6 QUIT
+7 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+8 ;
TALK ; EXTERNAL ENTERY POINT - TALK TO OPERATOR
+1 DO ^AUPNLK2B
+2 QUIT
+3 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+4 ;
ADDPAT ; ADD PATIENT
+1 IF $DATA(AUPLID)
IF DIC(0)["E"
WRITE !!?3,"Please enter the following additional information:",!?3
+2 KILL DD,DO
SET X=AUPX
IF $DATA(AUP("DR"))
SET DIC("DR")=AUP("DR")
DO FILE^DICN
SET DIC("W")=AUPDICW
IF $DATA(AUP("DR"))
KILL DIC("DR")
SET AUPDFN=Y
+3 IF +AUPDFN>0
LOCK +^DPT(+AUPDFN):10
DO IHSPAT
LOCK
+4 QUIT
+5 ;
IHSPAT ; ADD PATIENT TO 9000001
+1 KILL DD,DO
+2 FOR AUPV="DINUM","DIC","DIC(""DR"")","DIC(0)","DLAYGO"
IF $DATA(@AUPV)
SET AUPRCR(AUPV)=@AUPV
+3 SET X=+AUPDFN
SET DINUM=X
SET DIC="^AUPNPAT("
SET DIC(0)="L"
SET DLAYGO=9000001
SET DIC("DR")=".02////"_DT_";.11////"_DUZ
DO FILE^DICN
LOCK +^DPT(+AUPDFN):10
SET DIC("W")=AUPDICW
IF Y<0
DO IHSPATE
+4 KILL DINUM,DIC("DR"),DIC(0),DLAYGO
SET AUPV=""
FOR AUPL=0:0
SET AUPV=$ORDER(AUPRCR(AUPV))
IF AUPV=""
QUIT
SET @AUPV=AUPRCR(AUPV)
+5 KILL AUPRCR,AUPV
+6 QUIT
+7 ;
IHSPATE ; ERROR ADDING TO 9000001
+1 IF AUPRCR("DIC(0)")["Q"
WRITE !!?3,"Adding patient to ^AUPNPAT failed. Patient being removed from ^DPT also.",!
+2 SET DA=+AUPDFN
SET DIK="^DPT("
DO ^DIK
KILL DA,DIK
+3 SET AUPQF2=6
+4 QUIT
+5 ;
+6 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+7 ;
INIT ; EXTERNAL ENTERY POINT - INITIALIZATION
+1 SET AUPQF2=0
+2 IF '$DATA(DUZ(0))
IF DIC(0)["Q"
WRITE !?3,*7,"Unable to Add Patient. Your Fileman Access Code is undefined."
SET AUPQF2=1
QUIT
+3 DO ACCESS
KILL I,X
+4 IF AUPQF2
QUIT
+5 IF '($DATA(DUZ)#2)
SET DUZ=0
IF DUZ=""
SET DUZ=0
+6 ;AUPN*99.1*15, line below used to reference ^DIC(3
+7 IF '$DATA(^VA(200,DUZ))
IF DIC(0)["Q"
WRITE !?3,*7,"Unable to Add Patient. DUZ is not a valid user."
SET AUPQF2=1
QUIT
+8 QUIT
+9 ;
ACCESS ; CHECK FILEMAN ACCESS
+1 SET X=$SELECT(AUPDIC="^DPT(":2,1:9000001)
+2 IF $SELECT($DATA(DLAYGO):X-DLAYGO,1:1)
IF DUZ(0)'["@"
IF $DATA(^DIC(X,0,"LAYGO"))
SET X=^("LAYGO")
XECUTE "F I=1:1 I DUZ(0)[$E(X,I) Q"
IF I>$LENGTH(DUZ(0))
IF DIC(0)["Q"
WRITE !?3,*7,"Unable to Add Patient. You do not have Add authority."
SET AUPQF2=1
QUIT
+3 QUIT
+4 ;
+5 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+6 ;
EOJ ; EXTERNAL ENTRY POINT
+1 IF AUPQF2
SET AUPDFN=-1
+2 KILL AUPGID,AUPID,AUPID0,AUPIDS,AUPLID,AUP("DR"),AUPQF2,AUPRCR,AUPSET,AUPV
+3 QUIT
