- 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
