APCDLES1 ; IHS/CMI/LAB - SUICIDE FORM PART 2 ;
;;2.0;IHS PCC SUITE;**7**;MAY 14, 2009;Build 11
;
EN ;
W:$D(IOF) @IOF
W !!,$$CTR("*** Print Suicide Form ***"),!!
S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC
I Y=-1 D EXIT Q
S DFN=+Y
W !
D EP(DFN)
D EXIT
Q
EP(APCDSF) ;EP - when form is known
ZIS ;
W ! S DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen",DIR("A")="Do you wish to",DIR("B")="P" K DA D ^DIR K DIR
I $D(DIRUT) D EXIT Q
S APCDOPT=Y
I Y="B" D BROWSE,EXIT Q
S XBRP="PRINT^APCDLES1",XBRC="",XBRX="EXIT^APCDLES1",XBNS="APCD*;DFN"
D ^XBDBQUE
D EXIT
Q
BROWSE ;
S XBRP="VIEWR^XBLM(""PRINT^APCDLES1"")"
S XBRC="",XBRX="EXIT^APCDLES1",XBIOP=0 D ^XBDBQUE
Q
EXIT ;
K APCDOPT,APCDSF,APCDX,APCDOD,APCDSQIT,APCDQUIT,APCDO
;D EN^XBVK("APCD")
D ^XBFMK
Q
EP2(APCDSF) ;PEP - CALLED BY ICARE
NEW DFN,APCDO,APCDOD,X,Y,Z,A,DIWL,DIWR,DIWF,APCDX
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="1. Case #: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.01),$E(X,40)="Local Case #: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.02) D S(X,1)
S X="2. PROVIDER INITIALS: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.031),$E(X,40)="3. PROVIDER DISCIPLINE: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.032) D S(X,1)
S X="4. SEX: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.041),$E(X,25)="5. DOB: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.042),$E(X,58)="6. AGE: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.043) D S(X)
S X="7. EMPLOYMENT STATUS: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.05) D S(X)
S X="8. DATE OF ACT: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.06) D S(X)
S X="9. TRIBE: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.044) D S(X)
S X="10. COMMUNITY OF RESIDENCE: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.045) D S(X)
S X="11. COMMUNITY WHERE ACT OCCURRED: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.07) D S(X)
S X="12. RELATIONSHIP STATUS: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.08) D S(X,1)
;I $P(^AMHPSUIC(APCDSF,0),U,9)]"" S X=" RELATIONSHIP IF OTHER: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.09) D S(X)
S X="13. EDUCATION: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.11) D S(X,1)
I $P(^AMHPSUIC(APCDSF,0),U,12)]"" S X=" IF LESS THAN 12 YEARS, HIGHEST GRADE COMPLETED: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.12) D S(X)
S X="14. SELF DESTRUCTIVE ACT: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.13) D S(X,1)
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="15. METHOD: "_Y D S(X,1)
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)
S X="16. PREVIOUS ATTEMPTS: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.14) D S(X,1)
DRUG ;
S X="17. SUBSTANCE USE INVOLVED: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.26) D S(X,1)
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 X=" "_$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="18. LOCATION OF ACT: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.15) D S(X,1)
I $P($G(^AMHPSUIC(APCDSF,14)),U)]"" S X="18.1 LOCATION OF ACT, IF OTHER: "_$$VAL^XBDIQ1(9002011.65,APCDSF,1401) D S(X)
;S X="19. LETHALITY: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.24) D S(X,1)
S X="19. CONTRIBUTING FACTORS: " D S(X,1)
S Z=0 F S Z=$O(^AMHPSUIC(APCDSF,13,Z)) Q:Z'=+Z S X=" "_$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)
S X="20. DISPOSITION: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.25) D S(X,1)
I $P($G(^AMHPSUIC(APCDSF,14)),U,2)]"" S X="20.1 DISPOSITION, IF OTHER: "_$$VAL^XBDIQ1(9002011.65,APCDSF,1402) D S(X)
;S X="20b. INTERVENTION (COMPLETED): "_$$VAL^XBDIQ1(9002011.65,APCDSF,.17) D S(X,1)
;S X=" Describe in our own words what you believe contributed to this " D S(X,1)
S X=" Other Relevant Information: (OPTIONAL)" D S(X,1)
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
NEW X,L
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 ;
K ^TMP("APCDS",$J)
D EP2(APCDSF) ;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")
;----------
APCDLES1 ; IHS/CMI/LAB - SUICIDE FORM PART 2 ;
+1 ;;2.0;IHS PCC SUITE;**7**;MAY 14, 2009;Build 11
+2 ;
EN ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !!,$$CTR("*** Print Suicide Form ***"),!!
+3 SET DIC="^AUPNPAT("
SET DIC(0)="AEMQ"
DO ^DIC
+4 IF Y=-1
DO EXIT
QUIT
+5 SET DFN=+Y
+6 WRITE !
+7 DO EP(DFN)
+8 DO EXIT
+9 QUIT
EP(APCDSF) ;EP - when form is known
ZIS ;
+1 WRITE !
SET DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen"
SET DIR("A")="Do you wish to"
SET DIR("B")="P"
KILL DA
DO ^DIR
KILL DIR
+2 IF $DATA(DIRUT)
DO EXIT
QUIT
+3 SET APCDOPT=Y
+4 IF Y="B"
DO BROWSE
DO EXIT
QUIT
+5 SET XBRP="PRINT^APCDLES1"
SET XBRC=""
SET XBRX="EXIT^APCDLES1"
SET XBNS="APCD*;DFN"
+6 DO ^XBDBQUE
+7 DO EXIT
+8 QUIT
BROWSE ;
+1 SET XBRP="VIEWR^XBLM(""PRINT^APCDLES1"")"
+2 SET XBRC=""
SET XBRX="EXIT^APCDLES1"
SET XBIOP=0
DO ^XBDBQUE
+3 QUIT
EXIT ;
+1 KILL APCDOPT,APCDSF,APCDX,APCDOD,APCDSQIT,APCDQUIT,APCDO
+2 ;D EN^XBVK("APCD")
+3 DO ^XBFMK
+4 QUIT
EP2(APCDSF) ;PEP - CALLED BY ICARE
+1 NEW DFN,APCDO,APCDOD,X,Y,Z,A,DIWL,DIWR,DIWF,APCDX
+2 SET DFN=$PIECE(^AMHPSUIC(APCDSF,0),U,4)
+3 KILL ^TMP("APCDS",$JOB,"DCS")
+4 SET ^TMP("APCDS",$JOB,"DCS",0)=0
+5 DO SETARRAY
+6 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="1. Case #: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.01)
SET $EXTRACT(X,40)="Local Case #: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.02)
DO S(X,1)
+3 SET X="2. PROVIDER INITIALS: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.031)
SET $EXTRACT(X,40)="3. PROVIDER DISCIPLINE: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.032)
DO S(X,1)
+4 SET X="4. SEX: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.041)
SET $EXTRACT(X,25)="5. DOB: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.042)
SET $EXTRACT(X,58)="6. AGE: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.043)
DO S(X)
+5 SET X="7. EMPLOYMENT STATUS: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.05)
DO S(X)
+6 SET X="8. DATE OF ACT: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.06)
DO S(X)
+7 SET X="9. TRIBE: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.044)
DO S(X)
+8 SET X="10. COMMUNITY OF RESIDENCE: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.045)
DO S(X)
+9 SET X="11. COMMUNITY WHERE ACT OCCURRED: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.07)
DO S(X)
+10 SET X="12. RELATIONSHIP STATUS: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.08)
DO S(X,1)
+11 ;I $P(^AMHPSUIC(APCDSF,0),U,9)]"" S X=" RELATIONSHIP IF OTHER: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.09) D S(X)
+12 SET X="13. EDUCATION: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.11)
DO S(X,1)
+13 IF $PIECE(^AMHPSUIC(APCDSF,0),U,12)]""
SET X=" IF LESS THAN 12 YEARS, HIGHEST GRADE COMPLETED: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.12)
DO S(X)
+14 SET X="14. SELF DESTRUCTIVE ACT: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.13)
DO S(X,1)
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="15. METHOD: "_Y
DO S(X,1)
+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
+15 SET X="16. PREVIOUS ATTEMPTS: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.14)
DO S(X,1)
DRUG ;
+1 SET X="17. SUBSTANCE USE INVOLVED: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.26)
DO S(X,1)
+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 X=" "_$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="18. LOCATION OF ACT: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.15)
DO S(X,1)
+8 IF $PIECE($GET(^AMHPSUIC(APCDSF,14)),U)]""
SET X="18.1 LOCATION OF ACT, IF OTHER: "_$$VAL^XBDIQ1(9002011.65,APCDSF,1401)
DO S(X)
+9 ;S X="19. LETHALITY: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.24) D S(X,1)
+10 SET X="19. CONTRIBUTING FACTORS: "
DO S(X,1)
+11 SET Z=0
FOR
SET Z=$ORDER(^AMHPSUIC(APCDSF,13,Z))
IF Z'=+Z
QUIT
SET X=" "_$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)
+12 SET X="20. DISPOSITION: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.25)
DO S(X,1)
+13 IF $PIECE($GET(^AMHPSUIC(APCDSF,14)),U,2)]""
SET X="20.1 DISPOSITION, IF OTHER: "_$$VAL^XBDIQ1(9002011.65,APCDSF,1402)
DO S(X)
+14 ;S X="20b. INTERVENTION (COMPLETED): "_$$VAL^XBDIQ1(9002011.65,APCDSF,.17) D S(X,1)
+15 ;S X=" Describe in our own words what you believe contributed to this " D S(X,1)
+16 SET X=" Other Relevant Information: (OPTIONAL)"
DO S(X,1)
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 NEW X,L
+2 IF '$GET(F)
SET F=0
+3 IF '$GET(T)
SET T=0
+4 ;blank lines
+5 FOR F=1:1:F
SET X=""
DO S1
+6 SET X=Y
+7 IF $GET(C)
SET L=$LENGTH(Y)
SET T=(80-L)/2
Begin DoDot:1
+8 FOR %=1:1:(T-1)
SET X=" "_X
End DoDot:1
DO S1
QUIT
+9 FOR %=1:1:T
SET X=" "_Y
+10 DO S1
+11 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 ;
+1 KILL ^TMP("APCDS",$JOB)
+2 ;gather up data
DO EP2(APCDSF)
W ;write out array
+1 IF $DATA(IOF)
WRITE @IOF
+2 KILL APCDQUIT
+3 WRITE !,"********** CONFIDENTIAL PATIENT INFORMATION ["_$PIECE(^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 IF $Y>(IOSL-3)
DO HEADER
IF $DATA(APCDQUIT)
QUIT
+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 ;----------
