AUPNLK2.m

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