AGNAMCHG ;IHS/SD/EFG - ADD/EDIT NAME CHANGE DOC ;
;;7.1;PATIENT REGISTRATION;**4**;AUG 25,2005
;
Q
NAMCHG ;EP - PROOF OF NAME CHANGE
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 !,"DT CHANGED"
. W ?15,"CHANGED TO"
. W ?48,"PROOF"
. F S PTR=$O(^AUPNNAMC("C",DFN,PTR)) Q:'PTR D
.. S REC=$G(^AUPNNAMC(PTR,0))
.. S DTCHG=$P(REC,U)
.. S CHGTO=$P(REC,U,3)
.. S PRFPTR=$P(REC,U,4)
.. I PRFPTR>0 S PROOF=$P($G(^AUPNELM(PRFPTR,0)),U)
.. W !,$$FMTE^XLFDT(DTCHG,1)
.. W ?15,$E(CHGTO,1,30)
.. I PRFPTR>0 W ?48,$E(PROOF,1,30)
S DIR(0)="F"
S DIR("A")="Do you wish to E(dit) or A(dd) a new Proof of Name Change ? "
D ^DIR
Q:$D(DTOUT)!(Y="^")
I Y'="E"&(Y'="A") G NAMCHG
I Y="E" D EDITNAM
I Y="A" D ADDNAM
Q
EDITNAM ;EDIT PROOF OF NAME CHANGE
N DIE,DR,X,Y,DIR,REC,D
S DIC(0)="AEQZ"
S DA=DFN
S D="C"
S DIC("S")="I $P(^(0),U,2)=DFN"
S DIC="^AUPNNAMC("
D ^DIC S REC=+Y
Q:$D(DTOUT)!($D(DUOUT))!(Y=-1)
S DIE=DIC
S DA=REC
S DR=".03"
D ^DIE
I $P($G(^AUPNNAMC(DA,0)),U,3)="" D
. S DIK="^AUPNNAMC("
. S DA=REC
. D ^DIK
I $P($G(^AUPNNAMC(DA,0)),U,3)'="" D
. ;S DR=".04"
. S DR=".04;.05" ;AG*7.1*4 PER SCR
. S DA=REC
. D ^DIE
Q
ADDNAM ;EP - ADD PROOF OF NAME CHANGE
N DA,DIC,DD,DLAYGO,DO,X,Y
K DD,DO
K AG("NAMFAIL")
S DA=DFN
D NOW^%DTC
S X=%
S DIC="^AUPNNAMC("
S DIC(0)="L"
S DLAYGO=9000033
I $D(AG("NEWNAME")) D
. S DIC("DR")=".03///^S X=AG(""NEWNAME"");.04R;.05;.06////^S X=DUZ;.02////^S X=DFN"
E S DIC("DR")=".03R;.04R;.05;.06////^S X=DUZ;.02////^S X=DFN"
D ^DIC
I Y=-1 S AG("NAMFAIL")=""
Q:$D(DTOUT)!($D(DUOUT))!(Y=-1)
Q
AGNAMCHG ;IHS/SD/EFG - ADD/EDIT NAME CHANGE DOC ;
+1 ;;7.1;PATIENT REGISTRATION;**4**;AUG 25,2005
+2 ;
+3 QUIT
NAMCHG ;EP - PROOF OF NAME CHANGE
+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 !,"DT CHANGED"
+7 WRITE ?15,"CHANGED TO"
+8 WRITE ?48,"PROOF"
+9 FOR
SET PTR=$ORDER(^AUPNNAMC("C",DFN,PTR))
IF 'PTR
QUIT
Begin DoDot:2
+10 SET REC=$GET(^AUPNNAMC(PTR,0))
+11 SET DTCHG=$PIECE(REC,U)
+12 SET CHGTO=$PIECE(REC,U,3)
+13 SET PRFPTR=$PIECE(REC,U,4)
+14 IF PRFPTR>0
SET PROOF=$PIECE($GET(^AUPNELM(PRFPTR,0)),U)
+15 WRITE !,$$FMTE^XLFDT(DTCHG,1)
+16 WRITE ?15,$EXTRACT(CHGTO,1,30)
+17 IF PRFPTR>0
WRITE ?48,$EXTRACT(PROOF,1,30)
End DoDot:2
End DoDot:1
+18 SET DIR(0)="F"
+19 SET DIR("A")="Do you wish to E(dit) or A(dd) a new Proof of Name Change ? "
+20 DO ^DIR
+21 IF $DATA(DTOUT)!(Y="^")
QUIT
+22 IF Y'="E"&(Y'="A")
GOTO NAMCHG
+23 IF Y="E"
DO EDITNAM
+24 IF Y="A"
DO ADDNAM
+25 QUIT
EDITNAM ;EDIT PROOF OF NAME CHANGE
+1 NEW DIE,DR,X,Y,DIR,REC,D
+2 SET DIC(0)="AEQZ"
+3 SET DA=DFN
+4 SET D="C"
+5 SET DIC("S")="I $P(^(0),U,2)=DFN"
+6 SET DIC="^AUPNNAMC("
+7 DO ^DIC
SET REC=+Y
+8 IF $DATA(DTOUT)!($DATA(DUOUT))!(Y=-1)
QUIT
+9 SET DIE=DIC
+10 SET DA=REC
+11 SET DR=".03"
+12 DO ^DIE
+13 IF $PIECE($GET(^AUPNNAMC(DA,0)),U,3)=""
Begin DoDot:1
+14 SET DIK="^AUPNNAMC("
+15 SET DA=REC
+16 DO ^DIK
End DoDot:1
+17 IF $PIECE($GET(^AUPNNAMC(DA,0)),U,3)'=""
Begin DoDot:1
+18 ;S DR=".04"
+19 ;AG*7.1*4 PER SCR
SET DR=".04;.05"
+20 SET DA=REC
+21 DO ^DIE
End DoDot:1
+22 QUIT
ADDNAM ;EP - ADD PROOF OF NAME CHANGE
+1 NEW DA,DIC,DD,DLAYGO,DO,X,Y
+2 KILL DD,DO
+3 KILL AG("NAMFAIL")
+4 SET DA=DFN
+5 DO NOW^%DTC
+6 SET X=%
+7 SET DIC="^AUPNNAMC("
+8 SET DIC(0)="L"
+9 SET DLAYGO=9000033
+10 IF $DATA(AG("NEWNAME"))
Begin DoDot:1
+11 SET DIC("DR")=".03///^S X=AG(""NEWNAME"");.04R;.05;.06////^S X=DUZ;.02////^S X=DFN"
End DoDot:1
+12 IF '$TEST
SET DIC("DR")=".03R;.04R;.05;.06////^S X=DUZ;.02////^S X=DFN"
+13 DO ^DIC
+14 IF Y=-1
SET AG("NAMFAIL")=""
+15 IF $DATA(DTOUT)!($DATA(DUOUT))!(Y=-1)
QUIT
+16 QUIT
