- APCHGSUP ; IHS/CMI/LAB - display SUPPLEMENT ;
- ;;2.0;IHS PCC SUITE;**7**;MAY 14, 2009
- ;
- EN ;
- W:$D(IOF) @IOF
- W !!,$$CTR("*** Print Health Summary Supplement ***"),!!
- GETPAT ;
- S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC
- I Y=-1 D EXIT Q
- S (APCHSDFN,APCHSPAT,DFN)=+Y
- W !
- SUPP ;
- S APCHSUPT="",APCHSUPI=""
- S DIC="^APCHSUP(",DIC(0)="AEMQ",DIC("S")="I $G(^(14))]""""",DIC("A")="Select HEALTH SUMMARY SUPPLEMENT: " D ^DIC K DIC
- I Y=-1 G GETPAT
- S (APCHSUPT,APCHSUPI)=+Y
- I $D(^APCHSUP(APCHSUPI,15)) X ^APCHSUP(APCHSUPI,15) I $D(APCHSUPQ) W !!,"Supplement will not be generated." D EXIT Q
- I '$D(^APCHSUP(APCHSUPI,14)) W !!,"That supplement is not available with this option, you will need to",!,"display this supplement with a health summary.",! D EXIT Q
- 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 APCHOPT=Y
- I Y="B" D BROWSE,EXIT Q
- S XBRP="PRINT^APCHGSUP",XBRC="",XBRX="EXIT^APCHGSUP",XBNS="APCH;DFN"
- D ^XBDBQUE
- Q
- BROWSE ;
- S XBRP="VIEWR^XBLM(""PRINT^APCHGSUP"")"
- S XBRC="",XBRX="EXIT^APCHGSUP",XBIOP=0 D ^XBDBQUE
- Q
- EXIT ;
- D EN^XBVK("APCH")
- D ^XBFMK
- Q
- S(Y,F,C,T) ;set up array
- I '$G(F) S F=0
- I '$G(T) S T=0
- NEW %,X
- ;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("APCHS",$J,"DCS",0),U)+1,$P(^TMP("APCHS",$J,"DCS",0),U)=%
- S ^TMP("APCHS",$J,"DCS",%)=X
- Q
- PRINT ;
- OUTPUT ;
- K APCHSUPQ
- S Y=DT X ^DD("DD") S APCHSDAT=Y D NOW^%DTC S X=% X ^DD("FUNC",2,1) S APCHSTIM=X
- S APCHSCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$S($E(Y,6,7):$E(Y,6,7)_""/"",1:"""")_$E(Y,2,3)"
- S APCHSHDR="CONFIDENTIAL PATIENT INFORMATION -- "_$$FMTE^XLFDT(DT,5)_$J(APCHSTIM,9)_" ["_$P(^VA(200,DUZ,0),U,2)_"]" S X="",$P(X,"*",((IOM-6-$L(APCHSHDR))\2)+1)="*" S APCHSHDR=X_" "_APCHSHDR_" "_X
- K APCHQUIT
- S APCHPAGE=0,APCHQUIT=0
- K ^TMP("APCHS",$J)
- X ^APCHSUP(APCHSUPI,14)
- Q:$G(APCHSUPQ)
- W ;write out array
- W:$D(IOF) @IOF
- K APCHQUIT
- W !,"********** CONFIDENTIAL PATIENT INFORMATION ["_$P(^VA(200,DUZ,0),U,2)_"] "_$$FMTE^XLFDT(DT)_" **********"
- S APCHX=0 F S APCHX=$O(^TMP("APCHS",$J,"DCS",APCHX)) Q:APCHX'=+APCHX!($D(APCHQUIT)) D
- .I $Y>(IOSL-3) D HEADER Q:$D(APCHQUIT)
- .W !,^TMP("APCHS",$J,"DCS",APCHX)
- .Q
- I $D(APCHQUIT) S APCHSQIT=1
- D EOJ
- Q
- ;
- EOJ ;
- D PAUSE^APCHMT1
- K ^TMP("APCHS",$J)
- D EN^XBVK("APCH")
- 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 APCHQUIT="" 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")
- ;----------
- APCHGSUP ; IHS/CMI/LAB - display SUPPLEMENT ;
- +1 ;;2.0;IHS PCC SUITE;**7**;MAY 14, 2009
- +2 ;
- EN ;
- +1 IF $DATA(IOF)
- WRITE @IOF
- +2 WRITE !!,$$CTR("*** Print Health Summary Supplement ***"),!!
- GETPAT ;
- +1 SET DIC="^AUPNPAT("
- SET DIC(0)="AEMQ"
- DO ^DIC
- KILL DIC
- +2 IF Y=-1
- DO EXIT
- QUIT
- +3 SET (APCHSDFN,APCHSPAT,DFN)=+Y
- +4 WRITE !
- SUPP ;
- +1 SET APCHSUPT=""
- SET APCHSUPI=""
- +2 SET DIC="^APCHSUP("
- SET DIC(0)="AEMQ"
- SET DIC("S")="I $G(^(14))]"""""
- SET DIC("A")="Select HEALTH SUMMARY SUPPLEMENT: "
- DO ^DIC
- KILL DIC
- +3 IF Y=-1
- GOTO GETPAT
- +4 SET (APCHSUPT,APCHSUPI)=+Y
- +5 IF $DATA(^APCHSUP(APCHSUPI,15))
- XECUTE ^APCHSUP(APCHSUPI,15)
- IF $DATA(APCHSUPQ)
- WRITE !!,"Supplement will not be generated."
- DO EXIT
- QUIT
- +6 IF '$DATA(^APCHSUP(APCHSUPI,14))
- WRITE !!,"That supplement is not available with this option, you will need to",!,"display this supplement with a health summary.",!
- DO EXIT
- QUIT
- 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 APCHOPT=Y
- +4 IF Y="B"
- DO BROWSE
- DO EXIT
- QUIT
- +5 SET XBRP="PRINT^APCHGSUP"
- SET XBRC=""
- SET XBRX="EXIT^APCHGSUP"
- SET XBNS="APCH;DFN"
- +6 DO ^XBDBQUE
- +7 QUIT
- BROWSE ;
- +1 SET XBRP="VIEWR^XBLM(""PRINT^APCHGSUP"")"
- +2 SET XBRC=""
- SET XBRX="EXIT^APCHGSUP"
- SET XBIOP=0
- DO ^XBDBQUE
- +3 QUIT
- EXIT ;
- +1 DO EN^XBVK("APCH")
- +2 DO ^XBFMK
- +3 QUIT
- S(Y,F,C,T) ;set up array
- +1 IF '$GET(F)
- SET F=0
- +2 IF '$GET(T)
- SET T=0
- +3 NEW %,X
- +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("APCHS",$JOB,"DCS",0),U)+1
- SET $PIECE(^TMP("APCHS",$JOB,"DCS",0),U)=%
- +2 SET ^TMP("APCHS",$JOB,"DCS",%)=X
- +3 QUIT
- PRINT ;
- OUTPUT ;
- +1 KILL APCHSUPQ
- +2 SET Y=DT
- XECUTE ^DD("DD")
- SET APCHSDAT=Y
- DO NOW^%DTC
- SET X=%
- XECUTE ^DD("FUNC",2,1)
- SET APCHSTIM=X
- +3 SET APCHSCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$S($E(Y,6,7):$E(Y,6,7)_""/"",1:"""")_$E(Y,2,3)"
- +4 SET APCHSHDR="CONFIDENTIAL PATIENT INFORMATION -- "_$$FMTE^XLFDT(DT,5)_$JUSTIFY(APCHSTIM,9)_" ["_$PIECE(^VA(200,DUZ,0),U,2)_"]"
- SET X=""
- SET $PIECE(X,"*",((IOM-6-$LENGTH(APCHSHDR))\2)+1)="*"
- SET APCHSHDR=X_" "_APCHSHDR_" "_X
- +5 KILL APCHQUIT
- +6 SET APCHPAGE=0
- SET APCHQUIT=0
- +7 KILL ^TMP("APCHS",$JOB)
- +8 XECUTE ^APCHSUP(APCHSUPI,14)
- +9 IF $GET(APCHSUPQ)
- QUIT
- W ;write out array
- +1 IF $DATA(IOF)
- WRITE @IOF
- +2 KILL APCHQUIT
- +3 WRITE !,"********** CONFIDENTIAL PATIENT INFORMATION ["_$PIECE(^VA(200,DUZ,0),U,2)_"] "_$$FMTE^XLFDT(DT)_" **********"
- +4 SET APCHX=0
- FOR
- SET APCHX=$ORDER(^TMP("APCHS",$JOB,"DCS",APCHX))
- IF APCHX'=+APCHX!($DATA(APCHQUIT))
- QUIT
- Begin DoDot:1
- +5 IF $Y>(IOSL-3)
- DO HEADER
- IF $DATA(APCHQUIT)
- QUIT
- +6 WRITE !,^TMP("APCHS",$JOB,"DCS",APCHX)
- +7 QUIT
- End DoDot:1
- +8 IF $DATA(APCHQUIT)
- SET APCHSQIT=1
- +9 DO EOJ
- +10 QUIT
- +11 ;
- EOJ ;
- +1 DO PAUSE^APCHMT1
- +2 KILL ^TMP("APCHS",$JOB)
- +3 DO EN^XBVK("APCH")
- +4 KILL N,%,T,F,X,Y,B,C,E,F,H,L,N,P,T,W
- +5 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 APCHQUIT=""
- 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 ;----------