- 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
