AGED8 ; IHS/ASDS/EFG - EDIT DEATH INFO/OTHER NAMES ;
;;7.1;PATIENT REGISTRATION;**2**;JAN 31, 2007
;
S AG("N")=5
VAR D DRAW
Q:$D(AGSEENLY)
W !?10,"Enter ""4"" to edit OTHER NAMES or ""5"" to edit LEGAL NAMES."
W !,AGLINE("EQ")
I '$D(AGSEENLY) D
. K DIR
. S DIR("?")="Enter your choice now."
. S DIR("?",1)="You may enter the item number of the field you wish to edit,"
. S DIR("?",2)="OR you can enter 'P#' where P stands for 'page' and '#' stands for"
. S DIR("?",3)="the page you wish to jump to, OR enter '^' to go back one page"
. S DIR("?",4)="OR, enter '^^' to exit the edit screens, OR RETURN to go to the next screen."
. S DIR("A")="CHANGE which item? (1-"_AG("N")_") NONE// "
D READ^AGED1
Q:$D(DTOUT)!$D(DFOUT)
Q:$D(DUOUT)&$D(AGXTERN)
G ^AGED13:$D(DUOUT)&'$D(AGXTERN),VAR:$D(AG("ERR")),END:$D(DLOUT)!(Y["N") G:$D(AG("ED"))&'$D(AGXTERN) @("^AGED"_AG("ED"))
I $D(DQOUT)!(+Y<1)!(+Y>AG("N")) W !!,"You must enter a number from 1 to ",AG("N") H 2 G VAR
W !!
CC S AG("C")="DATE^AGED8,STATE^AGED8,CERT^AGED8,ALIAS^AG3A,NAMCHG^AGNAMCHG"
C ;EP - Edit multiple fields on a Reg edit page.
S AGY=Y F AGI=1:1 S AG("SEL")=+$P(AGY,",",AGI) Q:AG("SEL")<1!(AG("SEL")>AG("N")) D @($P(AG("C"),",",AG("SEL")))
D UPDATE1^AGED(DUZ(2),DFN,8,"") K AGI,AGY
G VAR
END K AG,DFOUT,DQOUT,DTOUT,DLOUT,DA,DIC,DIE,DR,AGSCRN,Y
K ROUTID
Q:$D(AGXTERN)
Q:$D(DIROUT)
Q:$D(AGSEENLY)
G ^AGED13:$D(DUOUT)
G ^AGED11
Q
DATE ;EP (string in AGED8).
K A S DIE="^DPT(",DR=.351,DA=DFN D ^DIE
I $D(^DPT(DFN,.35)) S $P(^AUPNPAT(DFN,11),U,29)=DT
;BEGIN NEW CODE IHS/SD/TPF 5/2/2006 AG*7.1*2 PAGE 12 ITEM 3
I $$AGE^AGUTILS(DFN)<3,($$DECEASED^AGEDERR2(AGPATDFN)) D AUTOADD^BIPATE(DFN,DUZ(2),.AGERR,$P($G(^DPT(DFN,.35)),U))
;END NEW CODE
Q
STATE ;EP (string in AGED8).
S DIE="^AUPNPAT(",DR=1115,DA=DFN D ^DIE Q
CERT ;EP (string in AGED8).
S DIE="^AUPNPAT(",DR=1116,DA=DFN D ^DIE Q
LEGNAM ;
N DIC,DIR,DA,X,Y
K DTOUT,DUOUT
I $D(^AUPNNAMC("C",DFN)) D
. S (PTR,REC,PRFPTR)=0
. S (DTCHG,CHGTO,PROOF)=""
. W !,"CHANGED TO"
. W ?32,"BY"
. W ?38,"PROOF"
. W ?54,"DOC. #"
. W ?70,"DATE"
. W !,"5. "
. F S PTR=$O(^AUPNNAMC("C",DFN,PTR)) Q:'PTR D
.. S REC=$G(^AUPNNAMC(PTR,0))
.. S DTCHG=$P($P(REC,U),".")
.. S CHGTO=$P(REC,U,3)
.. S PRFPTR=$P(REC,U,4)
.. S DOCNUM=$P(REC,U,5)
.. S USER=$P(REC,U,6)
.. I PRFPTR>0 S PROOF=$E($P($G(^AUPNELM(PRFPTR,0)),U),1,20)
.. W ?4,$E(CHGTO,1,30)
.. I USER>0 W ?32,$P($G(^VA(200,USER,0)),U,2)
.. I PRFPTR>0 W ?38,$E(PROOF,1,15)
.. W ?54,$E(DOCNUM,1,15)
.. W ?70,$E(DTCHG,4,5)_"/"_$E(DTCHG,6,7)_"/"_($E(DTCHG,1,3)+1700),!
Q
DRAW ;EP
S AG("PG")=7
S ROUTID=$P($T(+1)," ")
D ^AGED
K ^UTILITY("DIQ1",$J)
F AG=1:1 D Q:$G(AGSCRN)[("*END*")
. S AGSCRN=$P($T(@1+AG),";;",2,4)
. Q:AGSCRN[("*END*")
. S CAPTION=$P(AGSCRN,U)
. S DIC=$P(AGSCRN,U,3)
. S DR=$P(AGSCRN,U,4)
. S NEWLINE=$P(AGSCRN,U,5)
. S CAPDENT=$P(AGSCRN,U,2)
. W @NEWLINE,AG,".",@CAPDENT,$S($G(CAPTION)'="":CAPTION,1:$P($G(^DD(DIC,DR,0)),U))_" : "
. W $$GET1^DIQ(DIC,DFN,DR)
. I AG=1 D
.. I $P($G(^DPT(DFN,.35)),U,2)'="" D
... W ?45,"Edited by "_$P($G(^VA(200,$P($G(^DPT(DFN,.35)),U,2),0)),U,2)
.. I $P($G(^AUPNPAT(DFN,11)),U,29)'="" S Y=$P($G(^AUPNPAT(DFN,11)),U,29) D DD^%DT D
... W " on "_Y
W !,$E(AGLINE("-"),1,33) W ?33," Other Names ",$E(AGLINE("-"),1,34)
W !,"4. "
I $D(^DPT(DFN,.01,0)) D
.S DIC=2
.S DR(2.01)=.01
.S DR=1
.S DA=DFN
.S DAIEN=0
.F S DAIEN=$O(^DPT(DFN,.01,DAIEN)) Q:+DAIEN=0 D
.. S DA(2.01)=DAIEN
.. K AGRES
.. S DIQ="AGRES",DIQ(0)="E" D EN^DIQ1
.. W:$G(AGRES(2.01,DAIEN,.01,"E"))'="" ?4,$G(AGRES(2.01,DAIEN,.01,"E")),!
.. K AGRES,TEMPDIC,AGRES
W !,$E(AGLINE("-"),1,33) W ?33," Legal Names ",$E(AGLINE("-"),1,34)
D LEGNAM
Q
; ****************************************************************
; ON LINES BELOW:
; U "^" DELIMITED
; PIECE 1= FLD LBL
; PIECE 2= POSITION ON LINE TO DISP ITEM #
; PIECE 3= FILE #
; PIECE 4= FLD #
; PIECE 5= NEW LINE OR NOT (MUST BE EITHER A '!' OR '?#') USE THIS TO INDENT THE CAP
; PIECE 6= ITEM # OVERIDE. USE THIS TO ASSIGN THE ITEM # USED TO CHOOSE THIS
; FLD ON THE SCREEN
; PIECE 7= TAG TO CALL WHEN THIS FLD IS CHOSEN TO EDIT
;
; BAR "|" DELIMITED
; PIECE 2= EXECUTE CODE TO GET FLD THAT ANOTHER IS POINTING TO. EXECUTED AFT FLD PRINT
; PIECE 3= EXECUTE CODE TO DO BEF FLD DATA PRINTS. USE TO SCREEN OUT PRINTING A FLDS DATA
; PIECE 4= EXECUTE CODE TO DO BEF PRINTING THE CAP OR FLD LBL. USE TO SCREEN OUT PRINTING A CAP/FLD LBL
; PIECE 5= EXECUTE CODE TO DO AFT PRINTING THE FLD DATA
1 ;
;;^?11^2^.351^!^1
;;^?10^9000001^1115^!^2
;;^?3^9000001^1116^!^3
;;*END*
AGED8 ; IHS/ASDS/EFG - EDIT DEATH INFO/OTHER NAMES ;
+1 ;;7.1;PATIENT REGISTRATION;**2**;JAN 31, 2007
+2 ;
+3 SET AG("N")=5
VAR DO DRAW
+1 IF $DATA(AGSEENLY)
QUIT
+2 WRITE !?10,"Enter ""4"" to edit OTHER NAMES or ""5"" to edit LEGAL NAMES."
+3 WRITE !,AGLINE("EQ")
+4 IF '$DATA(AGSEENLY)
Begin DoDot:1
+5 KILL DIR
+6 SET DIR("?")="Enter your choice now."
+7 SET DIR("?",1)="You may enter the item number of the field you wish to edit,"
+8 SET DIR("?",2)="OR you can enter 'P#' where P stands for 'page' and '#' stands for"
+9 SET DIR("?",3)="the page you wish to jump to, OR enter '^' to go back one page"
+10 SET DIR("?",4)="OR, enter '^^' to exit the edit screens, OR RETURN to go to the next screen."
+11 SET DIR("A")="CHANGE which item? (1-"_AG("N")_") NONE// "
End DoDot:1
+12 DO READ^AGED1
+13 IF $DATA(DTOUT)!$DATA(DFOUT)
QUIT
+14 IF $DATA(DUOUT)&$DATA(AGXTERN)
QUIT
+15 IF $DATA(DUOUT)&'$DATA(AGXTERN)
GOTO ^AGED13
IF $DATA(AG("ERR"))
GOTO VAR
IF $DATA(DLOUT)!(Y["N")
GOTO END
IF $DATA(AG("ED"))&'$DATA(AGXTERN)
GOTO @("^AGED"_AG("ED"))
+16 IF $DATA(DQOUT)!(+Y<1)!(+Y>AG("N"))
WRITE !!,"You must enter a number from 1 to ",AG("N")
HANG 2
GOTO VAR
+17 WRITE !!
CC SET AG("C")="DATE^AGED8,STATE^AGED8,CERT^AGED8,ALIAS^AG3A,NAMCHG^AGNAMCHG"
C ;EP - Edit multiple fields on a Reg edit page.
+1 SET AGY=Y
FOR AGI=1:1
SET AG("SEL")=+$PIECE(AGY,",",AGI)
IF AG("SEL")<1!(AG("SEL")>AG("N"))
QUIT
DO @($PIECE(AG("C"),",",AG("SEL")))
+2 DO UPDATE1^AGED(DUZ(2),DFN,8,"")
KILL AGI,AGY
+3 GOTO VAR
END KILL AG,DFOUT,DQOUT,DTOUT,DLOUT,DA,DIC,DIE,DR,AGSCRN,Y
+1 KILL ROUTID
+2 IF $DATA(AGXTERN)
QUIT
+3 IF $DATA(DIROUT)
QUIT
+4 IF $DATA(AGSEENLY)
QUIT
+5 IF $DATA(DUOUT)
GOTO ^AGED13
+6 GOTO ^AGED11
+7 QUIT
DATE ;EP (string in AGED8).
+1 KILL A
SET DIE="^DPT("
SET DR=.351
SET DA=DFN
DO ^DIE
+2 IF $DATA(^DPT(DFN,.35))
SET $PIECE(^AUPNPAT(DFN,11),U,29)=DT
+3 ;BEGIN NEW CODE IHS/SD/TPF 5/2/2006 AG*7.1*2 PAGE 12 ITEM 3
+4 IF $$AGE^AGUTILS(DFN)<3
IF ($$DECEASED^AGEDERR2(AGPATDFN))
DO AUTOADD^BIPATE(DFN,DUZ(2),.AGERR,$PIECE($GET(^DPT(DFN,.35)),U))
+5 ;END NEW CODE
+6 QUIT
STATE ;EP (string in AGED8).
+1 SET DIE="^AUPNPAT("
SET DR=1115
SET DA=DFN
DO ^DIE
QUIT
CERT ;EP (string in AGED8).
+1 SET DIE="^AUPNPAT("
SET DR=1116
SET DA=DFN
DO ^DIE
QUIT
LEGNAM ;
+1 NEW DIC,DIR,DA,X,Y
+2 KILL DTOUT,DUOUT
+3 IF $DATA(^AUPNNAMC("C",DFN))
Begin DoDot:1
+4 SET (PTR,REC,PRFPTR)=0
+5 SET (DTCHG,CHGTO,PROOF)=""
+6 WRITE !,"CHANGED TO"
+7 WRITE ?32,"BY"
+8 WRITE ?38,"PROOF"
+9 WRITE ?54,"DOC. #"
+10 WRITE ?70,"DATE"
+11 WRITE !,"5. "
+12 FOR
SET PTR=$ORDER(^AUPNNAMC("C",DFN,PTR))
IF 'PTR
QUIT
Begin DoDot:2
+13 SET REC=$GET(^AUPNNAMC(PTR,0))
+14 SET DTCHG=$PIECE($PIECE(REC,U),".")
+15 SET CHGTO=$PIECE(REC,U,3)
+16 SET PRFPTR=$PIECE(REC,U,4)
+17 SET DOCNUM=$PIECE(REC,U,5)
+18 SET USER=$PIECE(REC,U,6)
+19 IF PRFPTR>0
SET PROOF=$EXTRACT($PIECE($GET(^AUPNELM(PRFPTR,0)),U),1,20)
+20 WRITE ?4,$EXTRACT(CHGTO,1,30)
+21 IF USER>0
WRITE ?32,$PIECE($GET(^VA(200,USER,0)),U,2)
+22 IF PRFPTR>0
WRITE ?38,$EXTRACT(PROOF,1,15)
+23 WRITE ?54,$EXTRACT(DOCNUM,1,15)
+24 WRITE ?70,$EXTRACT(DTCHG,4,5)_"/"_$EXTRACT(DTCHG,6,7)_"/"_($EXTRACT(DTCHG,1,3)+1700),!
End DoDot:2
End DoDot:1
+25 QUIT
DRAW ;EP
+1 SET AG("PG")=7
+2 SET ROUTID=$PIECE($TEXT(+1)," ")
+3 DO ^AGED
+4 KILL ^UTILITY("DIQ1",$JOB)
+5 FOR AG=1:1
Begin DoDot:1
+6 SET AGSCRN=$PIECE($TEXT(@1+AG),";;",2,4)
+7 IF AGSCRN[("*END*")
QUIT
+8 SET CAPTION=$PIECE(AGSCRN,U)
+9 SET DIC=$PIECE(AGSCRN,U,3)
+10 SET DR=$PIECE(AGSCRN,U,4)
+11 SET NEWLINE=$PIECE(AGSCRN,U,5)
+12 SET CAPDENT=$PIECE(AGSCRN,U,2)
+13 WRITE @NEWLINE,AG,".",@CAPDENT,$SELECT($GET(CAPTION)'="":CAPTION,1:$PIECE($GET(^DD(DIC,DR,0)),U))_" : "
+14 WRITE $$GET1^DIQ(DIC,DFN,DR)
+15 IF AG=1
Begin DoDot:2
+16 IF $PIECE($GET(^DPT(DFN,.35)),U,2)'=""
Begin DoDot:3
+17 WRITE ?45,"Edited by "_$PIECE($GET(^VA(200,$PIECE($GET(^DPT(DFN,.35)),U,2),0)),U,2)
End DoDot:3
+18 IF $PIECE($GET(^AUPNPAT(DFN,11)),U,29)'=""
SET Y=$PIECE($GET(^AUPNPAT(DFN,11)),U,29)
DO DD^%DT
Begin DoDot:3
+19 WRITE " on "_Y
End DoDot:3
End DoDot:2
End DoDot:1
IF $GET(AGSCRN)[("*END*")
QUIT
+20 WRITE !,$EXTRACT(AGLINE("-"),1,33)
WRITE ?33," Other Names ",$EXTRACT(AGLINE("-"),1,34)
+21 WRITE !,"4. "
+22 IF $DATA(^DPT(DFN,.01,0))
Begin DoDot:1
+23 SET DIC=2
+24 SET DR(2.01)=.01
+25 SET DR=1
+26 SET DA=DFN
+27 SET DAIEN=0
+28 FOR
SET DAIEN=$ORDER(^DPT(DFN,.01,DAIEN))
IF +DAIEN=0
QUIT
Begin DoDot:2
+29 SET DA(2.01)=DAIEN
+30 KILL AGRES
+31 SET DIQ="AGRES"
SET DIQ(0)="E"
DO EN^DIQ1
+32 IF $GET(AGRES(2.01,DAIEN,.01,"E"))'=""
WRITE ?4,$GET(AGRES(2.01,DAIEN,.01,"E")),!
+33 KILL AGRES,TEMPDIC,AGRES
End DoDot:2
End DoDot:1
+34 WRITE !,$EXTRACT(AGLINE("-"),1,33)
WRITE ?33," Legal Names ",$EXTRACT(AGLINE("-"),1,34)
+35 DO LEGNAM
+36 QUIT
+37 ; ****************************************************************
+38 ; ON LINES BELOW:
+39 ; U "^" DELIMITED
+40 ; PIECE 1= FLD LBL
+41 ; PIECE 2= POSITION ON LINE TO DISP ITEM #
+42 ; PIECE 3= FILE #
+43 ; PIECE 4= FLD #
+44 ; PIECE 5= NEW LINE OR NOT (MUST BE EITHER A '!' OR '?#') USE THIS TO INDENT THE CAP
+45 ; PIECE 6= ITEM # OVERIDE. USE THIS TO ASSIGN THE ITEM # USED TO CHOOSE THIS
+46 ; FLD ON THE SCREEN
+47 ; PIECE 7= TAG TO CALL WHEN THIS FLD IS CHOSEN TO EDIT
+48 ;
+49 ; BAR "|" DELIMITED
+50 ; PIECE 2= EXECUTE CODE TO GET FLD THAT ANOTHER IS POINTING TO. EXECUTED AFT FLD PRINT
+51 ; PIECE 3= EXECUTE CODE TO DO BEF FLD DATA PRINTS. USE TO SCREEN OUT PRINTING A FLDS DATA
+52 ; PIECE 4= EXECUTE CODE TO DO BEF PRINTING THE CAP OR FLD LBL. USE TO SCREEN OUT PRINTING A CAP/FLD LBL
+53 ; PIECE 5= EXECUTE CODE TO DO AFT PRINTING THE FLD DATA
1 ;
+1 ;;^?11^2^.351^!^1
+2 ;;^?10^9000001^1115^!^2
+3 ;;^?3^9000001^1116^!^3
+4 ;;*END*
