- 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
