AGLDOC ;IHS/SD/EFG - ADD/EDIT LEGAL DOCS ;
;;7.1;PATIENT REGISTRATION;;AUG 25,2005
;
LDOC ;EP - ASK ADD OR EDIT LEGAL DOCUMENTS ENTRY
N DA,DIC,DD,DLAYGO,DO,X,Y,DIK
K DD,DO
I $D(^AUPNPLDC("C",DFN)) D
. S (PTR,REC,DOCPTR)=0
. S (ENT,DOC,ADD,DOCNUM,EFFDT,ENDDT,ENTBY)=""
. W !,"ENTRY DT/TIME"
. W ?23,"DOCUMENT"
. W ?64,"DT ADDED TO FILE"
. W !,$G(AGLINE("-"))
. F S PTR=$O(^AUPNPLDC("C",DFN,PTR)) Q:'PTR D
.. S REC=$G(^AUPNPLDC(PTR,0))
.. S ENT=$P(REC,U)
.. S DOCPTR=$P(REC,U,3)
.. I $D(^AUPNELM(DOCPTR)) S DOC=$P(^AUPNELM(DOCPTR,0),U)
.. S ADD=$P(REC,U,4)
.. W !,$$FMTE^XLFDT(ENT,1)
.. W ?23,$E(DOC,1,38)
.. W ?64,$$FMTE^XLFDT(ADD,1)
.. S DOCNUM=$P(REC,U,5)
.. S EFFDT=$P(REC,U,6)
.. S ENDDT=$P(REC,U,7)
.. I $P(REC,U,8)'="" S ENTBY=$P(^VA(200,$P(REC,U,8),0),U)
.. W !,"DOC#: ",DOCNUM
.. W ?29,"EFF DT: ",$$FMTE^XLFDT(EFFDT,1)
.. W ?55,"END DT: ",$$FMTE^XLFDT(ENDDT,1)
.. W !,"ENTERED BY: ",ENTBY
.. W !,$G(AGLINE("-"))
K DIR,X,Y
S DIR(0)="F"
S DIR("A")="Do you wish to E(dit) or A(dd) a new legal doc ?"
D ^DIR
Q:$D(DTOUT)!$D(DIRUT)!$D(DUOUT)
I Y'="E"&(Y'="A")&(Y'="a")&(Y'="e") G LDOC
I Y="E"!(Y="e") D EDTDOC
I Y="A"!(Y="a") D ADDDOC
Q
ADDDOC ;ADD NEW LEGAL DOC
N DA,DIC,DD,DLAYGO,DO,X,Y,REC
K DD,DO
S DA=DFN
D NOW^%DTC
S X=%
S DIC="^AUPNPLDC("
S DIC(0)="L"
S DLAYGO=9000034
S DIC("DR")=".03R;.04R;.05;.06;.07;.02////^S X=DFN;.08////^S X=DUZ"
D ^DIC S REC=+Y
Q:$D(DTOUT)!$D(DUOUT)!(REC=-1)
Q
EDTDOC ;EDIT LEGAL DOC
N DIE,DR,X,Y,REC,D
S DIC(0)="AEQZ"
S DA=DFN
S D="C"
S DIC("S")="I $P(^(0),U,2)=DFN"
S DIC="^AUPNPLDC("
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(^AUPNPLDC(DA,0)),U,3)="" D
. S DIK="^AUPNPLDC("
. S DA=REC
. D ^DIK
I $P($G(^AUPNPLDC(DA,0)),U,3)'="" D
. S DR=".04;.05;.06;.07;.08////^S X=DUZ"
. S DA=REC
. D ^DIE
Q
AGLDOC ;IHS/SD/EFG - ADD/EDIT LEGAL DOCS ;
+1 ;;7.1;PATIENT REGISTRATION;;AUG 25,2005
+2 ;
LDOC ;EP - ASK ADD OR EDIT LEGAL DOCUMENTS ENTRY
+1 NEW DA,DIC,DD,DLAYGO,DO,X,Y,DIK
+2 KILL DD,DO
+3 IF $DATA(^AUPNPLDC("C",DFN))
Begin DoDot:1
+4 SET (PTR,REC,DOCPTR)=0
+5 SET (ENT,DOC,ADD,DOCNUM,EFFDT,ENDDT,ENTBY)=""
+6 WRITE !,"ENTRY DT/TIME"
+7 WRITE ?23,"DOCUMENT"
+8 WRITE ?64,"DT ADDED TO FILE"
+9 WRITE !,$GET(AGLINE("-"))
+10 FOR
SET PTR=$ORDER(^AUPNPLDC("C",DFN,PTR))
IF 'PTR
QUIT
Begin DoDot:2
+11 SET REC=$GET(^AUPNPLDC(PTR,0))
+12 SET ENT=$PIECE(REC,U)
+13 SET DOCPTR=$PIECE(REC,U,3)
+14 IF $DATA(^AUPNELM(DOCPTR))
SET DOC=$PIECE(^AUPNELM(DOCPTR,0),U)
+15 SET ADD=$PIECE(REC,U,4)
+16 WRITE !,$$FMTE^XLFDT(ENT,1)
+17 WRITE ?23,$EXTRACT(DOC,1,38)
+18 WRITE ?64,$$FMTE^XLFDT(ADD,1)
+19 SET DOCNUM=$PIECE(REC,U,5)
+20 SET EFFDT=$PIECE(REC,U,6)
+21 SET ENDDT=$PIECE(REC,U,7)
+22 IF $PIECE(REC,U,8)'=""
SET ENTBY=$PIECE(^VA(200,$PIECE(REC,U,8),0),U)
+23 WRITE !,"DOC#: ",DOCNUM
+24 WRITE ?29,"EFF DT: ",$$FMTE^XLFDT(EFFDT,1)
+25 WRITE ?55,"END DT: ",$$FMTE^XLFDT(ENDDT,1)
+26 WRITE !,"ENTERED BY: ",ENTBY
+27 WRITE !,$GET(AGLINE("-"))
End DoDot:2
End DoDot:1
+28 KILL DIR,X,Y
+29 SET DIR(0)="F"
+30 SET DIR("A")="Do you wish to E(dit) or A(dd) a new legal doc ?"
+31 DO ^DIR
+32 IF $DATA(DTOUT)!$DATA(DIRUT)!$DATA(DUOUT)
QUIT
+33 IF Y'="E"&(Y'="A")&(Y'="a")&(Y'="e")
GOTO LDOC
+34 IF Y="E"!(Y="e")
DO EDTDOC
+35 IF Y="A"!(Y="a")
DO ADDDOC
+36 QUIT
ADDDOC ;ADD NEW LEGAL DOC
+1 NEW DA,DIC,DD,DLAYGO,DO,X,Y,REC
+2 KILL DD,DO
+3 SET DA=DFN
+4 DO NOW^%DTC
+5 SET X=%
+6 SET DIC="^AUPNPLDC("
+7 SET DIC(0)="L"
+8 SET DLAYGO=9000034
+9 SET DIC("DR")=".03R;.04R;.05;.06;.07;.02////^S X=DFN;.08////^S X=DUZ"
+10 DO ^DIC
SET REC=+Y
+11 IF $DATA(DTOUT)!$DATA(DUOUT)!(REC=-1)
QUIT
+12 QUIT
EDTDOC ;EDIT LEGAL DOC
+1 NEW DIE,DR,X,Y,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="^AUPNPLDC("
+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(^AUPNPLDC(DA,0)),U,3)=""
Begin DoDot:1
+14 SET DIK="^AUPNPLDC("
+15 SET DA=REC
+16 DO ^DIK
End DoDot:1
+17 IF $PIECE($GET(^AUPNPLDC(DA,0)),U,3)'=""
Begin DoDot:1
+18 SET DR=".04;.05;.06;.07;.08////^S X=DUZ"
+19 SET DA=REC
+20 DO ^DIE
End DoDot:1
+21 QUIT
