APCDESF1 ; IHS/CMI/LAB - HS IN DATA ENTRY ;
;;2.0;IHS PCC SUITE;**7**;MAY 14, 2009
;
EP ;EP - called from input template
I $G(AUPNPAT)="" W !!,$C(7),$C(7),"Sorry I don't know the patient.",! Q
PROV ;
D ^XBFMK
S APCDSFDP=""
W !! S DIC("A")="Enter the Provider who completed the Form: ",DIC="^VA(200,",DIC(0)="AEMQ",DIC("B")=$P(^VA(200,DUZ,0),U) D ^DIC K DIC,DA,DR,DLAYGO,DIADD
I Y<0 W !,"No Provider Selected." D EXIT Q
S APCDSFPR=+Y
GETDATE ;EP - GET DATE OF ENCOUNTER
W !!
S APCDSFDT="",DIR(0)="DO^:"_DT_":EPTX",DIR("A")="Enter the DATE of the SUICIDE ACT" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) D EXIT G PROV
S APCDSFDT=Y
S APCDSFQT=""
S APCDSFI=$$HAVEONE(AUPNPAT,APCDSFDT)
I APCDSFI D G:'APCDSFQT EDIT I APCDSFQT D EXIT Q
.W !!,"There is already a suicide form on file for ",$P(^DPT(AUPNPAT,0),U)," on ",!,$$FMTE^XLFDT(APCDSFDT),"."
.W !,"If this is an addition of a new form, Please notify ",$P(^VA(200,APCDSFPR,0),U)
.W !,"that a form has already been entered by ",$$VAL^XBDIQ1(9002011.65,APCDSFI,.03),".",!!
.K DIR S DIR(0)="Y",DIR("A")="Do you want to continue and EDIT this form",DIR("B")="N" KILL DA D ^DIR KILL DIR
.I $D(DIRUT) S APCDSFQT=1 Q
.I 'Y S APCDSFQT=1 Q
K DD,D0,DO,DINUM,DIC,DA,DR S DIC(0)="EL",DIC="^AMHPSUIC(",DLAYGO=9002011.65,DIADD=1,X=$$UPI(AUPNPAT,APCDSFDT),DIC("DR")=".06////"_APCDSFDT_";.04////"_AUPNPAT_";.03////"_APCDSFPR_";.18////"_DT_";.19////"_DUZ_";.21////"_DT_";.22////"_DUZ
S DIC("DR")=DIC("DR")_";9901///1"
D FILE^DICN K DIC,DR,DIE,DIADD,DLAYGO,X,D0
I Y=-1 W !!,$C(7),$C(7),"Error creating Suicide form!! Deleting form.",! D EXIT Q
S APCDSFI=+Y
EDIT ;
W !!,"Please note: If while entering the data from the suicide form you make"
W !,"a mistake, you can edit the field by '^' jumping to that field."
W !,"For example: to go back to edit EMPLOYMENT STATUS after you have passed"
W !," that field, type ^EMPLOY and you will be taken back to that"
W !," field to edit it.",!
S DA=APCDSFI,DIE="^AMHPSUIC(",DR="[APCD SF EDIT]" D ^DIE
;display form and ask if okay to save otherwise edit again
D DISPLAY(APCDSFI)
;OKAY?
K DIR S DIR(0)="S^Y:Yes, save it;N:No, I wish to edit the data",DIR("A")="Are you finished entering this suicide form",DIR("B")="Y" KILL DA D ^DIR KILL DIR
I $D(DIRUT) D EXIT Q
I Y'="Y" G EDIT
D EXIT
Q
EXIT ;
D EN^XBVK("APCD")
D ^XBFMK
Q
;
UPI(P,D) ;
I '$G(P) Q ""
I '$P($G(^AUTTSITE(1,1)),U,3) S $P(^AUTTSITE(1,1),U,3)=$P(^AUTTLOC($P(^AUTTSITE(1,0),U,1),0),U,10)
;
Q $P(^AUTTSITE(1,1),U,3)_$E(D,4,5)_$E(D,6,7)_(1700+$E(D,1,3))_$E("0000000000",1,10-$L(P))_P
;
HAVEONE(P,D) ;is there a suicide form on file for this patient, this date, pass back ien
NEW Y
S Y=$$UPI(P,D)
I $D(^AMHPSUIC("B",Y)) Q $O(^AMHPSUIC("B",Y,0))
Q ""
;
DISPLAY(APCDSF) ;
W !!,"I will now display the form back to you so you can check"
W !,"the accuracy of the entry of the data.",!
K DIR S DIR(0)="E",DIR("A")="Press Enter to Continue" KILL DA D ^DIR KILL DIR
S XBRP="VIEWR^XBLM(""PRINT^APCDESF1"")"
S XBRC="",XBRX="EXIT1^APCDESF1",XBIOP=0 D ^XBDBQUE
Q
EXIT1 ;
D ^XBFMK
Q
EP2(APCDSF) ;
S DFN=$P(^AMHPSUIC(APCDSF,0),U,4)
K ^TMP("APCDS",$J,"DCS")
S ^TMP("APCDS",$J,"DCS",0)=0
D SETARRAY
Q
SETARRAY ;set up array containing dm care summary
S X="Suicide Reporting Form Date Printed: "_$$FMTE^XLFDT(DT) D S(X)
S X="Case #: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.01) D S(X)
S X="Local Case #: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.02) D S(X)
S X="COMMUNITY WHERE ACT OCCURRED: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.07) D S(X)
S X="DATE OF ACT: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.06) D S(X)
S X="PROVIDER FILLING OUT FORM: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.03) D S(X)
S X="EMPLOYMENT STATUS: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.05) D S(X)
S X="RELATIONSHIP STATUS: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.08) D S(X)
S X="EDUCATION: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.11) D S(X)
I $P(^AMHPSUIC(APCDSF,0),U,12)]"" S X=" IF LESS THAN 12 YEARS, HIGHEST GRADE: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.12) D S(X)
S X="SELF DESTRUCTIVE ACT: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.13) D S(X)
S X="LOCATION OF ACT: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.15) D S(X)
I $P($G(^AMHPSUIC(APCDSF,14)),U)]"" S X=" LOCATION OF ACT, IF OTHER: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,1401) D S(X)
S X="PREVIOUS ATTEMPTS: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.14) D S(X)
MET ;
K APCDOD,APCDO S Y="",Z=0 F S Z=$O(^AMHPSUIC(APCDSF,11,Z)) Q:Z'=+Z S Y=Y_$$EXTSET^XBFUNC(9002011.6511,.01,$P(^AMHPSUIC(APCDSF,11,Z,0),U))_" " D
.I $P(^AMHPSUIC(APCDSF,11,Z,0),U,2)]"" S APCDO(Z)=$P(^AMHPSUIC(APCDSF,11,Z,0),U,2)
.S A=0 F S A=$O(^AMHPSUIC(APCDSF,11,Z,11,A)) Q:A'=+A D
..S APCDOD(Z,A)=$P(^AMHTSDRG($P(^AMHPSUIC(APCDSF,11,Z,11,A,0),U),0),U)_" "_$P(^AMHPSUIC(APCDSF,11,Z,11,A,0),U,2)
..Q
S X="METHOD: ",$E(X,40)=Y D S(X)
I $D(APCDO) S X=" OTHER METHOD: " D
.S A=0 F S A=$O(APCDO(A)) Q:A'=+A S X=X_APCDO(A)_" "
.D S(X)
I $D(APCDOD) D
.S X=" DRUGS W/OVERDOSE: "
.S Y=0 F S Y=$O(APCDOD(Y)) Q:Y'=+Y D
..S A=0 F S A=$O(APCDOD(Y,A)) Q:A'=+A S X=X_APCDOD(Y,A)_" "
.D S(X)
DRUG ;
S X="SUBSTANCE USE INVOLVED: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.26) D S(X)
I $P(^AMHPSUIC(APCDSF,0),U,26)=2 D
.S X=" ALCOHOL OR DRUGS INVOLVED: "
.S Y=0 F S Y=$O(^AMHPSUIC(APCDSF,15,Y)) Q:Y'=+Y D
..S A=$P(^AMHPSUIC(APCDSF,15,Y,0),U) I A S $E(X,40)=$P($G(^AMHTSSU(A,0)),U) D S(X)
..S X=$P(^AMHPSUIC(APCDSF,15,Y,0),U,2) I X]"" S X=" OTHER DRUG: "_X D S(X)
S X="CONTRIBUTING FACTORS: " D S(X)
S Z=0 F S Z=$O(^AMHPSUIC(APCDSF,13,Z)) Q:Z'=+Z S X="",$E(X,20)=$P(^AMHTSCF($P(^AMHPSUIC(APCDSF,13,Z,0),U),0),U) S:$P(^AMHPSUIC(APCDSF,13,Z,0),U,2)]"" X=X_" - "_$P(^AMHPSUIC(APCDSF,13,Z,0),U,2) D S(X)
I $$VAL^XBDIQ1(9002011.65,APCDSF,.24)]"" S X="LETHALITY: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.24) D S(X)
S X="DISPOSITION: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.25) D S(X)
I $P($G(^AMHPSUIC(APCDSF,14)),U,2)]"" S X=" DISPOSITION, IF OTHER: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,1402) D S(X)
S X=" Narrative: " D S(X)
WP ;
K ^UTILITY($J,"W")
S APCDX=0
S DIWL=5,DIWR=75 F S APCDX=$O(^AMHPSUIC(APCDSF,41,APCDX)) Q:APCDX'=+APCDX D
.S X=^AMHPSUIC(APCDSF,41,APCDX,0) D ^DIWP
.Q
WPS ;
S Z=0 F S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z S X="",$E(X,5)=^UTILITY($J,"W",DIWL,Z,0) D S(X)
K DIWL,DIWR,DIWF,Z
K ^UTILITY($J,"W"),APCDX
Q
S(Y,F,C,T) ;set up array
I '$G(F) S F=0
I '$G(T) S T=0
;blank lines
F F=1:1:F S X="" D S1
S X=Y
I $G(C) S L=$L(Y),T=(80-L)/2 D D S1 Q
.F %=1:1:(T-1) S X=" "_X
F %=1:1:T S X=" "_Y
D S1
Q
S1 ;
S %=$P(^TMP("APCDS",$J,"DCS",0),U)+1,$P(^TMP("APCDS",$J,"DCS",0),U)=%
S ^TMP("APCDS",$J,"DCS",%)=X
Q
PRINT ;EP
K ^TMP("APCDS",$J)
D EP2(APCDSFI) ;gather up data
W ;write out array
;W:$D(IOF) @IOF
K APCDQUIT
;W !,"********** CONFIDENTIAL PATIENT INFORMATION ["_$P(^VA(200,DUZ,0),U,2)_"] "_$$FMTE^XLFDT(DT)_" **********"
S APCDX=0 F S APCDX=$O(^TMP("APCDS",$J,"DCS",APCDX)) Q:APCDX'=+APCDX!($D(APCDQUIT)) D
.;I $Y>(IOSL-3) D HEADER Q:$D(APCDQUIT)
.W !,^TMP("APCDS",$J,"DCS",APCDX)
.Q
I $D(APCDQUIT) S APCDSQIT=1
D EOJ
Q
;
EOJ ;
K ^TMP("APCDS",$J)
K APCDX,APCDQUIT,APCDY,APCDSBEG,APCDSTOB,APCDSUPI,APCDSED,APCDTOBN,APCDTOB,APCDOD,APCDO,X,Y,Z,APCDOPT,APCDSF,APCDSQIT,APCDOD
K N,%,T,F,X,Y,B,C,E,F,H,L,N,P,T,W
Q
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCDQUIT="" Q
HEAD1 ;
W:$D(IOF) @IOF
W !,"********** CONFIDENTIAL PATIENT INFORMATION ["_$P(^VA(200,DUZ,0),U,2)_"] "_$$FMTE^XLFDT(DT)_" **********",!!
Q
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
USR() ;EP - Return name of current user from ^VA(200.
Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
;----------
EPDE ;EP
D EN^XBNEW("EP^APCDESF1","AUPN*;VALM*") K Y
Q
APCDESF1 ; IHS/CMI/LAB - HS IN DATA ENTRY ;
+1 ;;2.0;IHS PCC SUITE;**7**;MAY 14, 2009
+2 ;
EP ;EP - called from input template
+1 IF $GET(AUPNPAT)=""
WRITE !!,$CHAR(7),$CHAR(7),"Sorry I don't know the patient.",!
QUIT
PROV ;
+1 DO ^XBFMK
+2 SET APCDSFDP=""
+3 WRITE !!
SET DIC("A")="Enter the Provider who completed the Form: "
SET DIC="^VA(200,"
SET DIC(0)="AEMQ"
SET DIC("B")=$PIECE(^VA(200,DUZ,0),U)
DO ^DIC
KILL DIC,DA,DR,DLAYGO,DIADD
+4 IF Y<0
WRITE !,"No Provider Selected."
DO EXIT
QUIT
+5 SET APCDSFPR=+Y
GETDATE ;EP - GET DATE OF ENCOUNTER
+1 WRITE !!
+2 SET APCDSFDT=""
SET DIR(0)="DO^:"_DT_":EPTX"
SET DIR("A")="Enter the DATE of the SUICIDE ACT"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+3 IF $DATA(DIRUT)
DO EXIT
GOTO PROV
+4 SET APCDSFDT=Y
+5 SET APCDSFQT=""
+6 SET APCDSFI=$$HAVEONE(AUPNPAT,APCDSFDT)
+7 IF APCDSFI
Begin DoDot:1
+8 WRITE !!,"There is already a suicide form on file for ",$PIECE(^DPT(AUPNPAT,0),U)," on ",!,$$FMTE^XLFDT(APCDSFDT),"."
+9 WRITE !,"If this is an addition of a new form, Please notify ",$PIECE(^VA(200,APCDSFPR,0),U)
+10 WRITE !,"that a form has already been entered by ",$$VAL^XBDIQ1(9002011.65,APCDSFI,.03),".",!!
+11 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Do you want to continue and EDIT this form"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+12 IF $DATA(DIRUT)
SET APCDSFQT=1
QUIT
+13 IF 'Y
SET APCDSFQT=1
QUIT
End DoDot:1
IF 'APCDSFQT
GOTO EDIT
IF APCDSFQT
DO EXIT
QUIT
+14 KILL DD,D0,DO,DINUM,DIC,DA,DR
SET DIC(0)="EL"
SET DIC="^AMHPSUIC("
SET DLAYGO=9002011.65
SET DIADD=1
SET X=$$UPI(AUPNPAT,APCDSFDT)
SET DIC("DR")=".06////"_APCDSFDT_";.04////"_AUPNPAT_";.03////"_APCDSFPR_";.18////"_DT_";.19////"_DUZ_";.21////"_DT_";.22////"_DUZ
+15 SET DIC("DR")=DIC("DR")_";9901///1"
+16 DO FILE^DICN
KILL DIC,DR,DIE,DIADD,DLAYGO,X,D0
+17 IF Y=-1
WRITE !!,$CHAR(7),$CHAR(7),"Error creating Suicide form!! Deleting form.",!
DO EXIT
QUIT
+18 SET APCDSFI=+Y
EDIT ;
+1 WRITE !!,"Please note: If while entering the data from the suicide form you make"
+2 WRITE !,"a mistake, you can edit the field by '^' jumping to that field."
+3 WRITE !,"For example: to go back to edit EMPLOYMENT STATUS after you have passed"
+4 WRITE !," that field, type ^EMPLOY and you will be taken back to that"
+5 WRITE !," field to edit it.",!
+6 SET DA=APCDSFI
SET DIE="^AMHPSUIC("
SET DR="[APCD SF EDIT]"
DO ^DIE
+7 ;display form and ask if okay to save otherwise edit again
+8 DO DISPLAY(APCDSFI)
+9 ;OKAY?
+10 KILL DIR
SET DIR(0)="S^Y:Yes, save it;N:No, I wish to edit the data"
SET DIR("A")="Are you finished entering this suicide form"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+11 IF $DATA(DIRUT)
DO EXIT
QUIT
+12 IF Y'="Y"
GOTO EDIT
+13 DO EXIT
+14 QUIT
EXIT ;
+1 DO EN^XBVK("APCD")
+2 DO ^XBFMK
+3 QUIT
+4 ;
UPI(P,D) ;
+1 IF '$GET(P)
QUIT ""
+2 IF '$PIECE($GET(^AUTTSITE(1,1)),U,3)
SET $PIECE(^AUTTSITE(1,1),U,3)=$PIECE(^AUTTLOC($PIECE(^AUTTSITE(1,0),U,1),0),U,10)
+3 ;
+4 QUIT $PIECE(^AUTTSITE(1,1),U,3)_$EXTRACT(D,4,5)_$EXTRACT(D,6,7)_(1700+$EXTRACT(D,1,3))_$EXTRACT("0000000000",1,10-$LENGTH(P))_P
+5 ;
HAVEONE(P,D) ;is there a suicide form on file for this patient, this date, pass back ien
+1 NEW Y
+2 SET Y=$$UPI(P,D)
+3 IF $DATA(^AMHPSUIC("B",Y))
QUIT $ORDER(^AMHPSUIC("B",Y,0))
+4 QUIT ""
+5 ;
DISPLAY(APCDSF) ;
+1 WRITE !!,"I will now display the form back to you so you can check"
+2 WRITE !,"the accuracy of the entry of the data.",!
+3 KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Enter to Continue"
KILL DA
DO ^DIR
KILL DIR
+4 SET XBRP="VIEWR^XBLM(""PRINT^APCDESF1"")"
+5 SET XBRC=""
SET XBRX="EXIT1^APCDESF1"
SET XBIOP=0
DO ^XBDBQUE
+6 QUIT
EXIT1 ;
+1 DO ^XBFMK
+2 QUIT
EP2(APCDSF) ;
+1 SET DFN=$PIECE(^AMHPSUIC(APCDSF,0),U,4)
+2 KILL ^TMP("APCDS",$JOB,"DCS")
+3 SET ^TMP("APCDS",$JOB,"DCS",0)=0
+4 DO SETARRAY
+5 QUIT
SETARRAY ;set up array containing dm care summary
+1 SET X="Suicide Reporting Form Date Printed: "_$$FMTE^XLFDT(DT)
DO S(X)
+2 SET X="Case #: "
SET $EXTRACT(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.01)
DO S(X)
+3 SET X="Local Case #: "
SET $EXTRACT(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.02)
DO S(X)
+4 SET X="COMMUNITY WHERE ACT OCCURRED: "
SET $EXTRACT(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.07)
DO S(X)
+5 SET X="DATE OF ACT: "
SET $EXTRACT(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.06)
DO S(X)
+6 SET X="PROVIDER FILLING OUT FORM: "
SET $EXTRACT(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.03)
DO S(X)
+7 SET X="EMPLOYMENT STATUS: "
SET $EXTRACT(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.05)
DO S(X)
+8 SET X="RELATIONSHIP STATUS: "
SET $EXTRACT(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.08)
DO S(X)
+9 SET X="EDUCATION: "
SET $EXTRACT(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.11)
DO S(X)
+10 IF $PIECE(^AMHPSUIC(APCDSF,0),U,12)]""
SET X=" IF LESS THAN 12 YEARS, HIGHEST GRADE: "
SET $EXTRACT(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.12)
DO S(X)
+11 SET X="SELF DESTRUCTIVE ACT: "
SET $EXTRACT(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.13)
DO S(X)
+12 SET X="LOCATION OF ACT: "
SET $EXTRACT(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.15)
DO S(X)
+13 IF $PIECE($GET(^AMHPSUIC(APCDSF,14)),U)]""
SET X=" LOCATION OF ACT, IF OTHER: "
SET $EXTRACT(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,1401)
DO S(X)
+14 SET X="PREVIOUS ATTEMPTS: "
SET $EXTRACT(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.14)
DO S(X)
MET ;
+1 KILL APCDOD,APCDO
SET Y=""
SET Z=0
FOR
SET Z=$ORDER(^AMHPSUIC(APCDSF,11,Z))
IF Z'=+Z
QUIT
SET Y=Y_$$EXTSET^XBFUNC(9002011.6511,.01,$PIECE(^AMHPSUIC(APCDSF,11,Z,0),U))_" "
Begin DoDot:1
+2 IF $PIECE(^AMHPSUIC(APCDSF,11,Z,0),U,2)]""
SET APCDO(Z)=$PIECE(^AMHPSUIC(APCDSF,11,Z,0),U,2)
+3 SET A=0
FOR
SET A=$ORDER(^AMHPSUIC(APCDSF,11,Z,11,A))
IF A'=+A
QUIT
Begin DoDot:2
+4 SET APCDOD(Z,A)=$PIECE(^AMHTSDRG($PIECE(^AMHPSUIC(APCDSF,11,Z,11,A,0),U),0),U)_" "_$PIECE(^AMHPSUIC(APCDSF,11,Z,11,A,0),U,2)
+5 QUIT
End DoDot:2
End DoDot:1
+6 SET X="METHOD: "
SET $EXTRACT(X,40)=Y
DO S(X)
+7 IF $DATA(APCDO)
SET X=" OTHER METHOD: "
Begin DoDot:1
+8 SET A=0
FOR
SET A=$ORDER(APCDO(A))
IF A'=+A
QUIT
SET X=X_APCDO(A)_" "
+9 DO S(X)
End DoDot:1
+10 IF $DATA(APCDOD)
Begin DoDot:1
+11 SET X=" DRUGS W/OVERDOSE: "
+12 SET Y=0
FOR
SET Y=$ORDER(APCDOD(Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+13 SET A=0
FOR
SET A=$ORDER(APCDOD(Y,A))
IF A'=+A
QUIT
SET X=X_APCDOD(Y,A)_" "
End DoDot:2
+14 DO S(X)
End DoDot:1
DRUG ;
+1 SET X="SUBSTANCE USE INVOLVED: "
SET $EXTRACT(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.26)
DO S(X)
+2 IF $PIECE(^AMHPSUIC(APCDSF,0),U,26)=2
Begin DoDot:1
+3 SET X=" ALCOHOL OR DRUGS INVOLVED: "
+4 SET Y=0
FOR
SET Y=$ORDER(^AMHPSUIC(APCDSF,15,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+5 SET A=$PIECE(^AMHPSUIC(APCDSF,15,Y,0),U)
IF A
SET $EXTRACT(X,40)=$PIECE($GET(^AMHTSSU(A,0)),U)
DO S(X)
+6 SET X=$PIECE(^AMHPSUIC(APCDSF,15,Y,0),U,2)
IF X]""
SET X=" OTHER DRUG: "_X
DO S(X)
End DoDot:2
End DoDot:1
+7 SET X="CONTRIBUTING FACTORS: "
DO S(X)
+8 SET Z=0
FOR
SET Z=$ORDER(^AMHPSUIC(APCDSF,13,Z))
IF Z'=+Z
QUIT
SET X=""
SET $EXTRACT(X,20)=$PIECE(^AMHTSCF($PIECE(^AMHPSUIC(APCDSF,13,Z,0),U),0),U)
IF $PIECE(^AMHPSUIC(APCDSF,13,Z,0),U,2)]""
SET X=X_" - "_$PIECE(^AMHPSUIC(APCDSF,13,Z,0),U,2)
DO S(X)
+9 IF $$VAL^XBDIQ1(9002011.65,APCDSF,.24)]""
SET X="LETHALITY: "
SET $EXTRACT(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.24)
DO S(X)
+10 SET X="DISPOSITION: "
SET $EXTRACT(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.25)
DO S(X)
+11 IF $PIECE($GET(^AMHPSUIC(APCDSF,14)),U,2)]""
SET X=" DISPOSITION, IF OTHER: "
SET $EXTRACT(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,1402)
DO S(X)
+12 SET X=" Narrative: "
DO S(X)
WP ;
+1 KILL ^UTILITY($JOB,"W")
+2 SET APCDX=0
+3 SET DIWL=5
SET DIWR=75
FOR
SET APCDX=$ORDER(^AMHPSUIC(APCDSF,41,APCDX))
IF APCDX'=+APCDX
QUIT
Begin DoDot:1
+4 SET X=^AMHPSUIC(APCDSF,41,APCDX,0)
DO ^DIWP
+5 QUIT
End DoDot:1
WPS ;
+1 SET Z=0
FOR
SET Z=$ORDER(^UTILITY($JOB,"W",DIWL,Z))
IF Z'=+Z
QUIT
SET X=""
SET $EXTRACT(X,5)=^UTILITY($JOB,"W",DIWL,Z,0)
DO S(X)
+2 KILL DIWL,DIWR,DIWF,Z
+3 KILL ^UTILITY($JOB,"W"),APCDX
+4 QUIT
S(Y,F,C,T) ;set up array
+1 IF '$GET(F)
SET F=0
+2 IF '$GET(T)
SET T=0
+3 ;blank lines
+4 FOR F=1:1:F
SET X=""
DO S1
+5 SET X=Y
+6 IF $GET(C)
SET L=$LENGTH(Y)
SET T=(80-L)/2
Begin DoDot:1
+7 FOR %=1:1:(T-1)
SET X=" "_X
End DoDot:1
DO S1
QUIT
+8 FOR %=1:1:T
SET X=" "_Y
+9 DO S1
+10 QUIT
S1 ;
+1 SET %=$PIECE(^TMP("APCDS",$JOB,"DCS",0),U)+1
SET $PIECE(^TMP("APCDS",$JOB,"DCS",0),U)=%
+2 SET ^TMP("APCDS",$JOB,"DCS",%)=X
+3 QUIT
PRINT ;EP
+1 KILL ^TMP("APCDS",$JOB)
+2 ;gather up data
DO EP2(APCDSFI)
W ;write out array
+1 ;W:$D(IOF) @IOF
+2 KILL APCDQUIT
+3 ;W !,"********** CONFIDENTIAL PATIENT INFORMATION ["_$P(^VA(200,DUZ,0),U,2)_"] "_$$FMTE^XLFDT(DT)_" **********"
+4 SET APCDX=0
FOR
SET APCDX=$ORDER(^TMP("APCDS",$JOB,"DCS",APCDX))
IF APCDX'=+APCDX!($DATA(APCDQUIT))
QUIT
Begin DoDot:1
+5 ;I $Y>(IOSL-3) D HEADER Q:$D(APCDQUIT)
+6 WRITE !,^TMP("APCDS",$JOB,"DCS",APCDX)
+7 QUIT
End DoDot:1
+8 IF $DATA(APCDQUIT)
SET APCDSQIT=1
+9 DO EOJ
+10 QUIT
+11 ;
EOJ ;
+1 KILL ^TMP("APCDS",$JOB)
+2 KILL APCDX,APCDQUIT,APCDY,APCDSBEG,APCDSTOB,APCDSUPI,APCDSED,APCDTOBN,APCDTOB,APCDOD,APCDO,X,Y,Z,APCDOPT,APCDSF,APCDSQIT,APCDOD
+3 KILL N,%,T,F,X,Y,B,C,E,F,H,L,N,P,T,W
+4 QUIT
+1 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET APCDQUIT=""
QUIT
HEAD1 ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !,"********** CONFIDENTIAL PATIENT INFORMATION ["_$PIECE(^VA(200,DUZ,0),U,2)_"] "_$$FMTE^XLFDT(DT)_" **********",!!
+3 QUIT
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
USR() ;EP - Return name of current user from ^VA(200.
+1 QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
+2 ;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
+1 QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
+2 ;----------
EPDE ;EP
+1 DO EN^XBNEW("EP^APCDESF1","AUPN*;VALM*")
KILL Y
+2 QUIT
