APCHTPP ; IHS/CMI/LAB - DISPLAY HEALTH MAINTENANCE Best Practice Prompt ;
;;2.0;IHS PCC SUITE;**10**;MAY 14, 2009;Build 88
;; ;
EP ;EP - called from option to select and display a TP
W !!,"This option will display or print the description/logic of all Health",!,"Summary Best Practice Prompts.",!!
ZIS ;
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) G XIT
I $G(Y)="B" D BROWSE,XIT Q
S XBRC="PROCESS^APCHTPP",XBRP="PRINT^APCHTPP",XBRX="XIT^APCHTPP",XBNS="APCH"
D ^XBDBQUE
D XIT
Q
XIT ;
K J,K,X,Z,Y
D EN^XBVK("APCH")
Q
BROWSE ;
S XBRP="VIEWR^XBLM(""PRINT^APCHTPP"")"
S XBNS="APCH",XBRC="PROCESS^APCHTPP",XBRX="XIT^APCHTPP",XBIOP=0 D ^XBDBQUE
Q
;
PROCESS ; -- init variables and list array
S APCHJ=$J,APCHH=$H
S ^XTMP("APCHTPP",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_"PCC HEALTH SUMMARY REPORT"
K ^XTMP("APCHTPP",APCHJ,APCHH)
S ^XTMP("APCHTPP",APCHJ,APCHH,0)=0
S APCHN="",APCHTP=0 F S APCHN=$O(^APCHSURV("B",APCHN)) Q:APCHN="" S APCHTP=0 F S APCHTP=$O(^APCHSURV("B",APCHN,APCHTP)) Q:APCHTP'=+APCHTP D PROCESS1
K ^XTMP("APCHTPP",APCHJ,APCHH,0)
Q
PROCESS1 ;
Q:$P(^APCHSURV(APCHTP,0),U,3)="D"
Q:$P(^APCHSURV(APCHTP,0),U,7)'="T"
;gather up Best Practice Prompt for display
S X="",X="Best Practice Prompt:",$E(X,24)=$P(^APCHSURV(APCHTP,0),U) D S(X,1)
S X="",X="Status:",$E(X,24)=$$VAL^XBDIQ1(9001018,APCHTP,.03) D S(X)
S X="Description:" D S(X,1)
S Y=0 F S Y=$O(^APCHSURV(APCHTP,1,Y)) Q:Y'=+Y S X="",$E(X,2)=^APCHSURV(APCHTP,1,Y,0) D S(X)
S X="Best Practice Prompt Text: " D S(X,1)
S Y=0 F S Y=$O(^APCHSURV(APCHTP,12,Y)) Q:Y'=+Y S X="",$E(X,2)=^APCHSURV(APCHTP,12,Y,0) D S(X)
S X="Currently Defined Criteria in Use at this Facility:" D S(X,1)
S Y=0 F S Y=$O(^APCHSURV(APCHTP,11,Y)) Q:Y'=+Y D
.S Z="",$E(Z,2)="Sex: "_$S($P(^APCHSURV(APCHTP,11,Y,0),U)="F":"FEMALE",$P(^APCHSURV(APCHTP,11,Y,0),U)="M":"MALE",$P(^APCHSURV(APCHTP,11,Y,0),U)="B":"ALL GENDERS",$P(^APCHSURV(APCHTP,11,Y,0),U)="U":"UNKNOWN",1:"")
.S J=0 F S J=$O(^APCHSURV(APCHTP,11,Y,11,J)) Q:J'=+J D
..S X=Z,$E(X,21)="Mininum Age: "_$P(^APCHSURV(APCHTP,11,Y,11,J,0),U),$E(X,40)="Maximum Age: "_$P(^APCHSURV(APCHTP,11,Y,11,J,0),U,2),$E(X,60)="Frequency: "_$P(^APCHSURV(APCHTP,11,Y,11,J,0),U,3) D S(X)
..Q
S X="Currently defined on the following summary types:" D S(X,1)
S J=0 F S J=$O(^APCHSCTL(J)) Q:J'=+J D
.S K=0 F S K=$O(^APCHSCTL(J,5,K)) Q:K'=+K I $P(^APCHSCTL(J,5,K,0),U,2)=APCHTP S X="",$E(X,15)=$P(^APCHSCTL(J,0),U) D S(X)
.Q
S X=$TR($J("",80)," ","*") D S(X,2)
Q
;
;
PRINT ;EP - called from xbdbque
S APCHPG=0,APCHQ=0 D HEAD
S APCHX=0 F S APCHX=$O(^XTMP("APCHTPP",APCHJ,APCHH,APCHX)) Q:APCHX'=+APCHX!(APCHQ) D
.I $Y>(IOSL-3) D HEAD Q:APCHQ
.W !,^XTMP("APCHTPP",APCHJ,APCHH,APCHX)
.Q
K ^XTMP("APCHTPP",APCHJ,APCHH),APCHJ,APCHH
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(^XTMP("APCHTPP",APCHJ,APCHH,0),U)+1,$P(^XTMP("APCHTPP",APCHJ,APCHH,0),U)=%
S ^XTMP("APCHTPP",APCHJ,APCHH,%)=X
Q
HEAD I 'APCHPG G HEAD1
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCHQ=1 Q
HEAD1 ;
W:$D(IOF) @IOF S APCHPG=APCHPG+1
W !,$P(^VA(200,DUZ,0),U,2),?72,"Page ",APCHPG,!
W ?(80-$L($P(^DIC(4,DUZ(2),0),U))/2),$P(^DIC(4,DUZ(2),0),U),!
W $$CTR("HEALTH SUMMARY HEALTH MAINTENANCE BEST PRACTICE PROMPTS",80),!
W !,$TR($J("",80)," ","-")
Q
;
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
EOP ;EP - End of page.
Q:$E(IOST)'="C"
Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
NEW DIR
K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
S DIR(0)="E" D ^DIR
Q
;----------
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")
;----------
APCHTPP ; IHS/CMI/LAB - DISPLAY HEALTH MAINTENANCE Best Practice Prompt ;
+1 ;;2.0;IHS PCC SUITE;**10**;MAY 14, 2009;Build 88
+2 ;; ;
EP ;EP - called from option to select and display a TP
+1 WRITE !!,"This option will display or print the description/logic of all Health",!,"Summary Best Practice Prompts.",!!
ZIS ;
+1 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)
GOTO XIT
+3 IF $GET(Y)="B"
DO BROWSE
DO XIT
QUIT
+4 SET XBRC="PROCESS^APCHTPP"
SET XBRP="PRINT^APCHTPP"
SET XBRX="XIT^APCHTPP"
SET XBNS="APCH"
+5 DO ^XBDBQUE
+6 DO XIT
+7 QUIT
XIT ;
+1 KILL J,K,X,Z,Y
+2 DO EN^XBVK("APCH")
+3 QUIT
BROWSE ;
+1 SET XBRP="VIEWR^XBLM(""PRINT^APCHTPP"")"
+2 SET XBNS="APCH"
SET XBRC="PROCESS^APCHTPP"
SET XBRX="XIT^APCHTPP"
SET XBIOP=0
DO ^XBDBQUE
+3 QUIT
+4 ;
PROCESS ; -- init variables and list array
+1 SET APCHJ=$JOB
SET APCHH=$HOROLOG
+2 SET ^XTMP("APCHTPP",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_"PCC HEALTH SUMMARY REPORT"
+3 KILL ^XTMP("APCHTPP",APCHJ,APCHH)
+4 SET ^XTMP("APCHTPP",APCHJ,APCHH,0)=0
+5 SET APCHN=""
SET APCHTP=0
FOR
SET APCHN=$ORDER(^APCHSURV("B",APCHN))
IF APCHN=""
QUIT
SET APCHTP=0
FOR
SET APCHTP=$ORDER(^APCHSURV("B",APCHN,APCHTP))
IF APCHTP'=+APCHTP
QUIT
DO PROCESS1
+6 KILL ^XTMP("APCHTPP",APCHJ,APCHH,0)
+7 QUIT
PROCESS1 ;
+1 IF $PIECE(^APCHSURV(APCHTP,0),U,3)="D"
QUIT
+2 IF $PIECE(^APCHSURV(APCHTP,0),U,7)'="T"
QUIT
+3 ;gather up Best Practice Prompt for display
+4 SET X=""
SET X="Best Practice Prompt:"
SET $EXTRACT(X,24)=$PIECE(^APCHSURV(APCHTP,0),U)
DO S(X,1)
+5 SET X=""
SET X="Status:"
SET $EXTRACT(X,24)=$$VAL^XBDIQ1(9001018,APCHTP,.03)
DO S(X)
+6 SET X="Description:"
DO S(X,1)
+7 SET Y=0
FOR
SET Y=$ORDER(^APCHSURV(APCHTP,1,Y))
IF Y'=+Y
QUIT
SET X=""
SET $EXTRACT(X,2)=^APCHSURV(APCHTP,1,Y,0)
DO S(X)
+8 SET X="Best Practice Prompt Text: "
DO S(X,1)
+9 SET Y=0
FOR
SET Y=$ORDER(^APCHSURV(APCHTP,12,Y))
IF Y'=+Y
QUIT
SET X=""
SET $EXTRACT(X,2)=^APCHSURV(APCHTP,12,Y,0)
DO S(X)
+10 SET X="Currently Defined Criteria in Use at this Facility:"
DO S(X,1)
+11 SET Y=0
FOR
SET Y=$ORDER(^APCHSURV(APCHTP,11,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+12 SET Z=""
SET $EXTRACT(Z,2)="Sex: "_$SELECT($PIECE(^APCHSURV(APCHTP,11,Y,0),U)="F":"FEMALE",$PIECE(^APCHSURV(APCHTP,11,Y,0),U)="M":"MALE",$PIECE(^APCHSURV(APCHTP,11,Y,0),U)="B":"ALL GENDERS",$PIECE(^APCHSURV(APCHTP,11,Y,0),U)="U":"UNKNOWN",1:"")
+13 SET J=0
FOR
SET J=$ORDER(^APCHSURV(APCHTP,11,Y,11,J))
IF J'=+J
QUIT
Begin DoDot:2
+14 SET X=Z
SET $EXTRACT(X,21)="Mininum Age: "_$PIECE(^APCHSURV(APCHTP,11,Y,11,J,0),U)
SET $EXTRACT(X,40)="Maximum Age: "_$PIECE(^APCHSURV(APCHTP,11,Y,11,J,0),U,2)
SET $EXTRACT(X,60)="Frequency: "_$PIECE(^APCHSURV(APCHTP,11,Y,11,J,0),U,3)
DO S(X)
+15 QUIT
End DoDot:2
End DoDot:1
+16 SET X="Currently defined on the following summary types:"
DO S(X,1)
+17 SET J=0
FOR
SET J=$ORDER(^APCHSCTL(J))
IF J'=+J
QUIT
Begin DoDot:1
+18 SET K=0
FOR
SET K=$ORDER(^APCHSCTL(J,5,K))
IF K'=+K
QUIT
IF $PIECE(^APCHSCTL(J,5,K,0),U,2)=APCHTP
SET X=""
SET $EXTRACT(X,15)=$PIECE(^APCHSCTL(J,0),U)
DO S(X)
+19 QUIT
End DoDot:1
+20 SET X=$TRANSLATE($JUSTIFY("",80)," ","*")
DO S(X,2)
+21 QUIT
+22 ;
+23 ;
PRINT ;EP - called from xbdbque
+1 SET APCHPG=0
SET APCHQ=0
DO HEAD
+2 SET APCHX=0
FOR
SET APCHX=$ORDER(^XTMP("APCHTPP",APCHJ,APCHH,APCHX))
IF APCHX'=+APCHX!(APCHQ)
QUIT
Begin DoDot:1
+3 IF $Y>(IOSL-3)
DO HEAD
IF APCHQ
QUIT
+4 WRITE !,^XTMP("APCHTPP",APCHJ,APCHH,APCHX)
+5 QUIT
End DoDot:1
+6 KILL ^XTMP("APCHTPP",APCHJ,APCHH),APCHJ,APCHH
+7 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(^XTMP("APCHTPP",APCHJ,APCHH,0),U)+1
SET $PIECE(^XTMP("APCHTPP",APCHJ,APCHH,0),U)=%
+2 SET ^XTMP("APCHTPP",APCHJ,APCHH,%)=X
+3 QUIT
HEAD IF 'APCHPG
GOTO HEAD1
+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 APCHQ=1
QUIT
HEAD1 ;
+1 IF $DATA(IOF)
WRITE @IOF
SET APCHPG=APCHPG+1
+2 WRITE !,$PIECE(^VA(200,DUZ,0),U,2),?72,"Page ",APCHPG,!
+3 WRITE ?(80-$LENGTH($PIECE(^DIC(4,DUZ(2),0),U))/2),$PIECE(^DIC(4,DUZ(2),0),U),!
+4 WRITE $$CTR("HEALTH SUMMARY HEALTH MAINTENANCE BEST PRACTICE PROMPTS",80),!
+5 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+6 QUIT
+7 ;
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 ;----------
EOP ;EP - End of page.
+1 IF $EXTRACT(IOST)'="C"
QUIT
+2 IF $DATA(ZTQUEUED)!'(IOT="TRM")!$DATA(IO("S"))
QUIT
+3 NEW DIR
+4 KILL DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
+5 SET DIR(0)="E"
DO ^DIR
+6 QUIT
+7 ;----------
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 ;----------
