AGMANERS.m

AGMANERS ; IHS/OIT/SCR 06/22/06 - CHANGE PATIENT NAME API FOR ERS  ;

 ;;7.1;PATIENT REGISTRATION;**2,9**;AUG 25, 2005

 ;USED BY AMER*2.5.1 req 8

 ;

NAME(AMERDFN) ;EP - From UPDATPAT^AMERVSIT

 ;IHS/OIT/SCR 6/22/06 MODIFIED NAME^AGEMAN TO FORCE THIS DFN AND NO OTHER FOR 

 Q:AMERDFN 0

EDIT ;

 N DIC,AMERONAM

 S AMERONAM=$P($G(^DPT(AMERDFN,0)),U)

 S DFN=AMERDFN

 D CHKRHI^AG

 I $D(RHIFLAG)  D

 . I RHIFLAG="A" W !,$$S^AGVDF("RVN"),$$S^AGVDF("BLN"),"This patient has Restricted Health Information",$$S^AGVDF("BLF"),$$S^AGVDF("RVF")

 ;ADD ALERT IF PATIENT HAS 'DATE OF DEATH' POPULATED IN VA

 ;PATIENT FILE

 I $D(DFN) I $$CHKDEATH^AGEDERR(DFN) W !!?5,"**** ALERT: DATE OF DEATH ON FILE FOR THIS PATIENT!!" H 2

 Q:'$D(DFN) 0

 S DIR(0)="FOr^1:80",DIR("A")="ENTER NEW NAME",DIR("?")="ENTER NAME THAT SHOULD BE ON THIS RECORD(80 characters max.)"

 S DIR("B")=AMERONAM

 D ^DIR K DIR

 I $D(DUOUT)!$D(DTOUT)!(Y="") K DUOUT,DTOUT,Y Q 0

 Q:Y=AMERONAM 0

 ;W !!,"Enter the NEW NAME: " D READ^AG Q:Y=""  I Y="@" W !!,*7,"CANNOT DELETE PATIENTS THROUGH THIS ROUTINE." Q

 K AG("NEWNAME")

 S X=Y

 S AG("NEWNAME")=Y

 D NAME^AUPNPED

 I '$D(X) D EN^DDIOL("INCORRECT NAME FORMAT","","!!") K AG("NEWNAME") Q 0

 S AG("OLDNAME")=AMERONAM

 D NOW^%DTC S AGDTS=%

 D ADDNAM^AGNAMCHG

 Q:$D(AG("NAMFAIL")) 0

 K DIC,DIE,DA,DR,Y

 S DA=DFN

 S DR=".01///"_AG("NEWNAME")

 S X=$$DIEDPT(DA,DR)

 I $P(^DPT(DFN,0),U)=AG("OLDNAME") D END Q 1

 ;HL7 INTERFACE -- PUT PATIENT DFN INTO TEMP ARRAY FOR HL7 CALL

 S ^XTMP("AGHL7",DUZ(2),DA)=DA  ;AG*7.1*9 - Added DUZ(2) subscript

 S ^XTMP("AGHL7AG",DUZ(2),DA,"UPDATE")=""  ;AG*7.1*9 - Added DUZ(2) subscript

 S DIR("A")="Do you wish to store "_AG("OLDNAME")_" in the ""OTHER NAMES"" file for future reference to this patient"

 S DIR(0)="Y",DIR("B")="YES"

 D ^DIR

 I $D(DUOUT)!$D(DTOUT)!(Y="") K DUOUT,DTOUT,Y Q 0

 I Y["Y" D

 .S DIE="^DPT("

 .S DA=DFN,DR="1///"_AG("OLDNAME"),DR(2,2.01)=.01

 .S X=$$DIEDPT(DA,DR)

 S ^AGPATCH(AGDTS,DUZ(2),DFN)="",DR=".03///TODAY",$P(^AUPNPAT(DFN,0),U,12)=DUZ,DA=DFN

 D DIEAUPN(DA,DR)

 Q 1

END  ;AMER*2.5*1 IHS/OIT/SCR 09/01/06

 I '$G(AGTDS) S X="NOW" D ^%DT S AGDTS=Y

 I $G(AGPTPG)=0,("N"'[($P(^AUTTSITE(1,0),"^",16))) S ^AGPATCH(AGDTS,DUZ(2),DFN,"ZMFI",0)=""

 I $D(^AGPATCH(AGDTS,DUZ(2),DFN))=10 S ^AGPATCH(AGDTS,DUZ(2),DFN)=""

 I $D(^AGPATCH(AGDTS,DUZ(2),DFN))=0 S ^AGPATCH(AGDTS,DUZ(2),DFN)=""

 K AGDTS

 Q

DIEDPT(DA,DR) ; GIVEN AN ENTRY NUMBER AND A DR STRING, EDIT THE VA PATIENT 

FILE ;EP

 N X,Y,%

 N D,D0,DI,DIC,DICR,DIE,DIG,DIH,DIV,DIU,DIW,DQ

 S DIE="^DPT("

 L +^DPT(DA):3 E  Q

 D ^DIE

 L -^DPT(DA)

 K DIE,DA,DR

 Q X

DIEAUPN(DA,DR) ; GIVEN AN ENTRY NUMBER AND A DR STRING, EDIT THE PATIENT FILE

 N X,Y,%

 N D,D0,DI,DIC,DICR,DIE,DIG,DIH,DIV,DIU,DIW,DQ

 S DIE="^AUPNPAT("

 L +^AUPNPAT(DA):3 E  Q

 D ^DIE

 L -^AUPNPAT(DA)

 K DIE,DA,DR

 Q

AGMANERS  ; IHS/OIT/SCR 06/22/06 - CHANGE PATIENT NAME API FOR ERS  ;

 +1       ;;7.1;PATIENT REGISTRATION;**2,9**;AUG 25, 2005

 +2       ;USED BY AMER*2.5.1 req 8

 +3       ;

NAME(AMERDFN) ;EP - From UPDATPAT^AMERVSIT

 +1       ;IHS/OIT/SCR 6/22/06 MODIFIED NAME^AGEMAN TO FORCE THIS DFN AND NO OTHER FOR 

 +2        IF AMERDFN

               QUIT 0

EDIT      ;

 +1        NEW DIC,AMERONAM

 +2        SET AMERONAM=$PIECE($GET(^DPT(AMERDFN,0)),U)

 +3        SET DFN=AMERDFN

 +4        DO CHKRHI^AG

 +5        IF $DATA(RHIFLAG)

               Begin DoDot:1

 +6                IF RHIFLAG="A"

                       WRITE !,$$S^AGVDF("RVN"),$$S^AGVDF("BLN"),"This patient has Restricted Health Information",$$S^AGVDF("BLF"),$$S^AGVDF("RVF")

               End DoDot:1

 +7       ;ADD ALERT IF PATIENT HAS 'DATE OF DEATH' POPULATED IN VA

 +8       ;PATIENT FILE

 +9        IF $DATA(DFN)

               IF $$CHKDEATH^AGEDERR(DFN)

                   WRITE !!?5,"**** ALERT: DATE OF DEATH ON FILE FOR THIS PATIENT!!"

                   HANG 2

 +10       IF '$DATA(DFN)

               QUIT 0

 +11       SET DIR(0)="FOr^1:80"

           SET DIR("A")="ENTER NEW NAME"

           SET DIR("?")="ENTER NAME THAT SHOULD BE ON THIS RECORD(80 characters max.)"

 +12       SET DIR("B")=AMERONAM

 +13       DO ^DIR

           KILL DIR

 +14       IF $DATA(DUOUT)!$DATA(DTOUT)!(Y="")

               KILL DUOUT,DTOUT,Y

               QUIT 0

 +15       IF Y=AMERONAM

               QUIT 0

 +16      ;W !!,"Enter the NEW NAME: " D READ^AG Q:Y=""  I Y="@" W !!,*7,"CANNOT DELETE PATIENTS THROUGH THIS ROUTINE." Q

 +17       KILL AG("NEWNAME")

 +18       SET X=Y

 +19       SET AG("NEWNAME")=Y

 +20       DO NAME^AUPNPED

 +21       IF '$DATA(X)

               DO EN^DDIOL("INCORRECT NAME FORMAT","","!!")

               KILL AG("NEWNAME")

               QUIT 0

 +22       SET AG("OLDNAME")=AMERONAM

 +23       DO NOW^%DTC

           SET AGDTS=%

 +24       DO ADDNAM^AGNAMCHG

 +25       IF $DATA(AG("NAMFAIL"))

               QUIT 0

 +26       KILL DIC,DIE,DA,DR,Y

 +27       SET DA=DFN

 +28       SET DR=".01///"_AG("NEWNAME")

 +29       SET X=$$DIEDPT(DA,DR)

 +30       IF $PIECE(^DPT(DFN,0),U)=AG("OLDNAME")

               DO END

               QUIT 1

 +31      ;HL7 INTERFACE -- PUT PATIENT DFN INTO TEMP ARRAY FOR HL7 CALL

 +32      ;AG*7.1*9 - Added DUZ(2) subscript

           SET ^XTMP("AGHL7",DUZ(2),DA)=DA

 +33      ;AG*7.1*9 - Added DUZ(2) subscript

           SET ^XTMP("AGHL7AG",DUZ(2),DA,"UPDATE")=""

 +34       SET DIR("A")="Do you wish to store "_AG("OLDNAME")_" in the ""OTHER NAMES"" file for future reference to this patient"

 +35       SET DIR(0)="Y"

           SET DIR("B")="YES"

 +36       DO ^DIR

 +37       IF $DATA(DUOUT)!$DATA(DTOUT)!(Y="")

               KILL DUOUT,DTOUT,Y

               QUIT 0

 +38       IF Y["Y"

               Begin DoDot:1

 +39               SET DIE="^DPT("

 +40               SET DA=DFN

                   SET DR="1///"_AG("OLDNAME")

                   SET DR(2,2.01)=.01

 +41               SET X=$$DIEDPT(DA,DR)

               End DoDot:1

 +42       SET ^AGPATCH(AGDTS,DUZ(2),DFN)=""

           SET DR=".03///TODAY"

           SET $PIECE(^AUPNPAT(DFN,0),U,12)=DUZ

           SET DA=DFN

 +43       DO DIEAUPN(DA,DR)

 +44       QUIT 1

END       ;AMER*2.5*1 IHS/OIT/SCR 09/01/06

 +1        IF '$GET(AGTDS)

               SET X="NOW"

               DO ^%DT

               SET AGDTS=Y

 +2        IF $GET(AGPTPG)=0

               IF ("N"'[($PIECE(^AUTTSITE(1,0),"^",16)))

                   SET ^AGPATCH(AGDTS,DUZ(2),DFN,"ZMFI",0)=""

 +3        IF $DATA(^AGPATCH(AGDTS,DUZ(2),DFN))=10

               SET ^AGPATCH(AGDTS,DUZ(2),DFN)=""

 +4        IF $DATA(^AGPATCH(AGDTS,DUZ(2),DFN))=0

               SET ^AGPATCH(AGDTS,DUZ(2),DFN)=""

 +5        KILL AGDTS

 +6        QUIT 

DIEDPT(DA,DR) ; GIVEN AN ENTRY NUMBER AND A DR STRING, EDIT THE VA PATIENT 

FILE      ;EP

 +1        NEW X,Y,%

 +2        NEW D,D0,DI,DIC,DICR,DIE,DIG,DIH,DIV,DIU,DIW,DQ

 +3        SET DIE="^DPT("

 +4        LOCK +^DPT(DA):3

          IF '$TEST

               QUIT 

 +5        DO ^DIE

 +6        LOCK -^DPT(DA)

 +7        KILL DIE,DA,DR

 +8        QUIT X

DIEAUPN(DA,DR) ; GIVEN AN ENTRY NUMBER AND A DR STRING, EDIT THE PATIENT FILE

 +1        NEW X,Y,%

 +2        NEW D,D0,DI,DIC,DICR,DIE,DIG,DIH,DIV,DIU,DIW,DQ

 +3        SET DIE="^AUPNPAT("

 +4        LOCK +^AUPNPAT(DA):3

          IF '$TEST

               QUIT 

 +5        DO ^DIE

 +6        LOCK -^AUPNPAT(DA)

 +7        KILL DIE,DA,DR

 +8        QUIT