AGMAN ; IHS/ASDS/EFG - PATIENT EDIT ;
;;7.1;PATIENT REGISTRATION;**5,9**;AUG 25, 2005
NAME ;EP - From option.
D PTLK^AG
Q:'$D(DFN)
NAMEASK ;
W !!,"Enter the NEW NAME: " D READ^AG Q:Y="" I Y="@" W !!,*7,"CANNOT DELETE PATIENTS THROUGH THIS ROUTINE." Q
K AG("NEWNAME")
Q:$D(DUOUT)!$D(DTOUT)!$D(DFOUT)!$D(DQOUT)!$D(DLOUT)
S X=Y
S AG("NEWNAME")=Y
D NAME^AUPNPED
I '$D(X) W !!,"INCORRECT NAME FORMAT." K AG("NEWNAME") G NAMEASK
S AG("OLDNAME")=$P(^DPT(DFN,0),U)
D NOW^%DTC S AGDTS=%
D ADDNAM^AGNAMCHG
Q:$D(AG("NAMFAIL"))
K DIC,DIE,DA,DR,X,Y
S DIE="^DPT("
S DA=DFN
S DR=".01///"_AG("NEWNAME")
D ^DIE Q:'$D(X) G END:$P(^DPT(DFN,0),U)=AG("OLDNAME")
;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
NAME1 W !!,"Do you wish to store """,AG("OLDNAME"),"""",!,"in the ""OTHER NAMES"" file for future reference to this patient? (Y/N) " D READ^AG G NAME:$D(DUOUT) I $D(DQOUT)!$D(DLOUT)!("YN"'[Y) D YN^AG G NAME1
I Y["Y" S DIE="^DPT(",DA=DFN,DR="1///"_AG("OLDNAME"),DR(2,2.01)=.01 D ^DIE
S ^AGPATCH(AGDTS,DUZ(2),DFN)="",DIE="^AUPNPAT(",DR=".03///TODAY",$P(^AUPNPAT(DFN,0),U,12)=DUZ,DA=DFN D ^DIE
G END
CHART ;EP - From option.
KILL DOG
D PTLK^AG
Q:'$D(DFN)
CHART1 ;EP - From ^AG0 (Add Chart # to Patient)
S AG("EDIT")="" D ^AG1 I $D(DUOUT)!$D(DTOUT)!$D(DFOUT) G END
S DIE="^AUPNPAT(",DR=".03///TODAY",$P(^AUPNPAT(DFN,0),U,12)=DUZ,DA=DFN D ^DIE
S ^XTMP("AGHL7AG",DUZ(2),DFN,"UPDATE")="" ;fje 07082009 AG*7.1*5 EDR ;AG*7.1*9 - Added DUZ(2) subscript
D NOW^%DTC S AGDTS=%
I $D(AG("NEWREG")) S ^AGPATCH(AGDTS,DUZ(2),DFN)="NEW" D INITL,DELCHK G:'$D(AG("OCH")) END
I (AG("OCH")'=AG("CH"))&($E(AG("OCH"))="T") S ^AGPATCH(AGDTS,DUZ(2),DFN)="NEW" G END
G END:AG("OCH")=AG("CH") I $D(^AGPATCH(AGDTS,DUZ(2),DFN)) G END:$P(^(DFN),U,2)]""&($P(^(DFN),U,3)="") S:$P(^(DFN),U,2)]"" AG("OCH")=$P(^(DFN),U,2)
D INITL S ^AGPATCH(AGDTS,DUZ(2),DFN)=DUZ(2)_U_AG("OCH")_U_AG("CH")_U_AG("INITL")_U_$P(^DPT(DFN,0),U,2)
END ;
ZMFI ;EP called from the various page edits to tag AGPATCH with PG number
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
DEAD ;EP - Determine If a Patient is DECEASED.
K AG("DEAD") I $D(DFN),$D(^DPT(DFN,.35)),$P(^(.35),U) S AG("DEAD")=""
Q
DEADY ;EP - Is PATIENT DECEASED (IN FILEMANAGER).
K AG("DEAD") I $D(Y),$D(^DPT(Y,.35)),$P(^(.35),U) S AG("DEAD")=""
Q
INITL ;EP - PATIENT Initials -LAST NAME:FIRST NAME (ONLY).
K AG("INITL") I $D(DFN),$D(^DPT(DFN,0)) S AG("INITL")=$E($P(^(0),U))_$E($P($P(^(0),U),",",2))
Q
DELCHK ;Check for delete instruction in ^AGPATCH.
S AGTXSITE=$P(^AUTTSITE(1,0),U)
I '$D(^AGTXST(AGTXSITE)) S AGZDTS="" G DCHK1
S AGZDTS=+$P(^AGTXST(AGTXSITE,1,0),U,3) I 'AGZDTS G DCHK1
S AGZDTS=$P(^AGTXST(AGTXSITE,1,AGZDTS,0),U,3)
DCHK1 ;>PICK OLD HRN
F S AGZDTS=$O(^AGPATCH(AGZDTS)) Q:'AGZDTS I ($D(^(AGZDTS,DUZ(2),DFN))#2),+(^(DFN)),$P(^(DFN),U,3)="" S AG("OCH")=$P(^(DFN),U,2) K ^(DFN)
K AGTX,AGTXSITE,AGZDTS
Q
AGMAN ; IHS/ASDS/EFG - PATIENT EDIT ;
+1 ;;7.1;PATIENT REGISTRATION;**5,9**;AUG 25, 2005
NAME ;EP - From option.
+1 DO PTLK^AG
+2 IF '$DATA(DFN)
QUIT
NAMEASK ;
+1 WRITE !!,"Enter the NEW NAME: "
DO READ^AG
IF Y=""
QUIT
IF Y="@"
WRITE !!,*7,"CANNOT DELETE PATIENTS THROUGH THIS ROUTINE."
QUIT
+2 KILL AG("NEWNAME")
+3 IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DFOUT)!$DATA(DQOUT)!$DATA(DLOUT)
QUIT
+4 SET X=Y
+5 SET AG("NEWNAME")=Y
+6 DO NAME^AUPNPED
+7 IF '$DATA(X)
WRITE !!,"INCORRECT NAME FORMAT."
KILL AG("NEWNAME")
GOTO NAMEASK
+8 SET AG("OLDNAME")=$PIECE(^DPT(DFN,0),U)
+9 DO NOW^%DTC
SET AGDTS=%
+10 DO ADDNAM^AGNAMCHG
+11 IF $DATA(AG("NAMFAIL"))
QUIT
+12 KILL DIC,DIE,DA,DR,X,Y
+13 SET DIE="^DPT("
+14 SET DA=DFN
+15 SET DR=".01///"_AG("NEWNAME")
+16 DO ^DIE
IF '$DATA(X)
QUIT
IF $PIECE(^DPT(DFN,0),U)=AG("OLDNAME")
GOTO END
+17 ;HL7 INTERFACE -- PUT PATIENT DFN INTO TEMP ARRAY FOR HL7 CALL
+18 ;AG*7.1*9 - Added DUZ(2) subscript
SET ^XTMP("AGHL7",DUZ(2),DA)=DA
+19 ;AG*7.1*9 - Added DUZ(2) subscript
SET ^XTMP("AGHL7AG",DUZ(2),DA,"UPDATE")=""
NAME1 WRITE !!,"Do you wish to store """,AG("OLDNAME"),"""",!,"in the ""OTHER NAMES"" file for future reference to this patient? (Y/N) "
DO READ^AG
IF $DATA(DUOUT)
GOTO NAME
IF $DATA(DQOUT)!$DATA(DLOUT)!("YN"'[Y)
DO YN^AG
GOTO NAME1
+1 IF Y["Y"
SET DIE="^DPT("
SET DA=DFN
SET DR="1///"_AG("OLDNAME")
SET DR(2,2.01)=.01
DO ^DIE
+2 SET ^AGPATCH(AGDTS,DUZ(2),DFN)=""
SET DIE="^AUPNPAT("
SET DR=".03///TODAY"
SET $PIECE(^AUPNPAT(DFN,0),U,12)=DUZ
SET DA=DFN
DO ^DIE
+3 GOTO END
CHART ;EP - From option.
+1 KILL DOG
+2 DO PTLK^AG
+3 IF '$DATA(DFN)
QUIT
CHART1 ;EP - From ^AG0 (Add Chart # to Patient)
+1 SET AG("EDIT")=""
DO ^AG1
IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DFOUT)
GOTO END
+2 SET DIE="^AUPNPAT("
SET DR=".03///TODAY"
SET $PIECE(^AUPNPAT(DFN,0),U,12)=DUZ
SET DA=DFN
DO ^DIE
+3 ;fje 07082009 AG*7.1*5 EDR ;AG*7.1*9 - Added DUZ(2) subscript
SET ^XTMP("AGHL7AG",DUZ(2),DFN,"UPDATE")=""
+4 DO NOW^%DTC
SET AGDTS=%
+5 IF $DATA(AG("NEWREG"))
SET ^AGPATCH(AGDTS,DUZ(2),DFN)="NEW"
DO INITL
DO DELCHK
IF '$DATA(AG("OCH"))
GOTO END
+6 IF (AG("OCH")'=AG("CH"))&($EXTRACT(AG("OCH"))="T")
SET ^AGPATCH(AGDTS,DUZ(2),DFN)="NEW"
GOTO END
+7 IF AG("OCH")=AG("CH")
GOTO END
IF $DATA(^AGPATCH(AGDTS,DUZ(2),DFN))
IF $PIECE(^(DFN),U,2)]""&($PIECE(^(DFN),U,3)="")
GOTO END
IF $PIECE(^(DFN),U,2)]""
SET AG("OCH")=$PIECE(^(DFN),U,2)
+8 DO INITL
SET ^AGPATCH(AGDTS,DUZ(2),DFN)=DUZ(2)_U_AG("OCH")_U_AG("CH")_U_AG("INITL")_U_$PIECE(^DPT(DFN,0),U,2)
END ;
ZMFI ;EP called from the various page edits to tag AGPATCH with PG number
+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
DEAD ;EP - Determine If a Patient is DECEASED.
+1 KILL AG("DEAD")
IF $DATA(DFN)
IF $DATA(^DPT(DFN,.35))
IF $PIECE(^(.35),U)
SET AG("DEAD")=""
+2 QUIT
DEADY ;EP - Is PATIENT DECEASED (IN FILEMANAGER).
+1 KILL AG("DEAD")
IF $DATA(Y)
IF $DATA(^DPT(Y,.35))
IF $PIECE(^(.35),U)
SET AG("DEAD")=""
+2 QUIT
INITL ;EP - PATIENT Initials -LAST NAME:FIRST NAME (ONLY).
+1 KILL AG("INITL")
IF $DATA(DFN)
IF $DATA(^DPT(DFN,0))
SET AG("INITL")=$EXTRACT($PIECE(^(0),U))_$EXTRACT($PIECE($PIECE(^(0),U),",",2))
+2 QUIT
DELCHK ;Check for delete instruction in ^AGPATCH.
+1 SET AGTXSITE=$PIECE(^AUTTSITE(1,0),U)
+2 IF '$DATA(^AGTXST(AGTXSITE))
SET AGZDTS=""
GOTO DCHK1
+3 SET AGZDTS=+$PIECE(^AGTXST(AGTXSITE,1,0),U,3)
IF 'AGZDTS
GOTO DCHK1
+4 SET AGZDTS=$PIECE(^AGTXST(AGTXSITE,1,AGZDTS,0),U,3)
DCHK1 ;>PICK OLD HRN
+1 FOR
SET AGZDTS=$ORDER(^AGPATCH(AGZDTS))
IF 'AGZDTS
QUIT
IF ($DATA(^(AGZDTS,DUZ(2),DFN))#2)
IF +(^(DFN))
IF $PIECE(^(DFN),U,3)=""
SET AG("OCH")=$PIECE(^(DFN),U,2)
KILL ^(DFN)
+2 KILL AGTX,AGTXSITE,AGZDTS
+3 QUIT
