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
