APCHTPD ; 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:$D(IOF) @IOF
W !!,"This option will allow a site to inactivate or activate a Best Practice Prompt.",!!
EP1 ;
D ^XBFMK
S DIC="^APCHSURV(",DIC("A")="Select BEST PRACTICE PROMPT to Activate/Inactivate: ",DIC(0)="AEMQ",DIC("S")="I $P(^(0),U,3)'=""D"",$P(^(0),U,7)=""T""" D ^DIC
I Y=-1 D EXIT Q
S APCHTP=+Y
INIT ; -- init variables and list array
K ^TMP("APCHTPD",$J)
S ^TMP("APCHTPD",$J,0)=0
;gather up Best Practice Prompt for display
S C=0,X="",X="Best Practice Prompt:",$E(X,24)=$P(^APCHSURV(APCHTP,0),U) D S(X)
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)
I '$O(^APCHSURV(APCHTP,11,0)) S X="<<< No local criteria defined. >>>" D S(X)
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
.Q
;S X="Standard IHS Default Criteria" D S(X,2)
;S Y=0 F S Y=$O(^APCHSURV(APCHTP,81,Y)) Q:Y'=+Y D
;.S Z="",$E(Z,2)="Sex: "_$S($P(^APCHSURV(APCHTP,81,Y,0),U)="F":"FEMALE",$P(^APCHSURV(APCHTP,81,Y,0),U)="M":"MALE",$P(^APCHSURV(APCHTP,81,Y,0),U)="B":"BOTH",1:"")
;.S J=0 F S J=$O(^APCHSURV(APCHTP,81,Y,11,J)) Q:J'=+J D
;..S X=Z,$E(X,21)="Mininum Age: "_$P(^APCHSURV(APCHTP,81,Y,11,J,0),U),$E(X,40)="Maximum Age: "_$P(^APCHSURV(APCHTP,81,Y,11,J,0),U,2),$E(X,60)="Frequency: "_$P(^APCHSURV(APCHTP,81,Y,11,J,0),U,3) D S(X)
;..Q
;.Q
S APCHX=0 F S APCHX=$O(^TMP("APCHTPD",$J,APCHX)) Q:APCHX'=+APCHX D
.I $Y>(IOSL-4) K DIR S DIR(0)="E",DIR("A")="Press return to continue" D ^DIR K DIR W:$D(IOF) @IOF
.W !,^TMP("APCHTPD",$J,APCHX,0)
EDIT ;
D ^XBFMK
W ! S DIE="^APCHSURV(",DA=APCHTP,DR=".03" D ^DIE
W !! K DIR S DIR(0)="E",DIR("A")="Press return..." D ^DIR K DIR
D EXIT
Q
;
EXIT ; -- exit code
D EN^XBVK("APCH")
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("APCHTPD",$J,0),U)+1,$P(^TMP("APCHTPD",$J,0),U)=%
S ^TMP("APCHTPD",$J,%,0)=X
Q
APCHTPD ; 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 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !!,"This option will allow a site to inactivate or activate a Best Practice Prompt.",!!
EP1 ;
+1 DO ^XBFMK
+2 SET DIC="^APCHSURV("
SET DIC("A")="Select BEST PRACTICE PROMPT to Activate/Inactivate: "
SET DIC(0)="AEMQ"
SET DIC("S")="I $P(^(0),U,3)'=""D"",$P(^(0),U,7)=""T"""
DO ^DIC
+3 IF Y=-1
DO EXIT
QUIT
+4 SET APCHTP=+Y
INIT ; -- init variables and list array
+1 KILL ^TMP("APCHTPD",$JOB)
+2 SET ^TMP("APCHTPD",$JOB,0)=0
+3 ;gather up Best Practice Prompt for display
+4 SET C=0
SET X=""
SET X="Best Practice Prompt:"
SET $EXTRACT(X,24)=$PIECE(^APCHSURV(APCHTP,0),U)
DO S(X)
+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 IF '$ORDER(^APCHSURV(APCHTP,11,0))
SET X="<<< No local criteria defined. >>>"
DO S(X)
+12 SET Y=0
FOR
SET Y=$ORDER(^APCHSURV(APCHTP,11,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+13 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:"")
+14 SET J=0
FOR
SET J=$ORDER(^APCHSURV(APCHTP,11,Y,11,J))
IF J'=+J
QUIT
Begin DoDot:2
+15 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)
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 ;S X="Standard IHS Default Criteria" D S(X,2)
+19 ;S Y=0 F S Y=$O(^APCHSURV(APCHTP,81,Y)) Q:Y'=+Y D
+20 ;.S Z="",$E(Z,2)="Sex: "_$S($P(^APCHSURV(APCHTP,81,Y,0),U)="F":"FEMALE",$P(^APCHSURV(APCHTP,81,Y,0),U)="M":"MALE",$P(^APCHSURV(APCHTP,81,Y,0),U)="B":"BOTH",1:"")
+21 ;.S J=0 F S J=$O(^APCHSURV(APCHTP,81,Y,11,J)) Q:J'=+J D
+22 ;..S X=Z,$E(X,21)="Mininum Age: "_$P(^APCHSURV(APCHTP,81,Y,11,J,0),U),$E(X,40)="Maximum Age: "_$P(^APCHSURV(APCHTP,81,Y,11,J,0),U,2),$E(X,60)="Frequency: "_$P(^APCHSURV(APCHTP,81,Y,11,J,0),U,3) D S(X)
+23 ;..Q
+24 ;.Q
+25 SET APCHX=0
FOR
SET APCHX=$ORDER(^TMP("APCHTPD",$JOB,APCHX))
IF APCHX'=+APCHX
QUIT
Begin DoDot:1
+26 IF $Y>(IOSL-4)
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press return to continue"
DO ^DIR
KILL DIR
IF $DATA(IOF)
WRITE @IOF
+27 WRITE !,^TMP("APCHTPD",$JOB,APCHX,0)
End DoDot:1
EDIT ;
+1 DO ^XBFMK
+2 WRITE !
SET DIE="^APCHSURV("
SET DA=APCHTP
SET DR=".03"
DO ^DIE
+3 WRITE !!
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press return..."
DO ^DIR
KILL DIR
+4 DO EXIT
+5 QUIT
+6 ;
EXIT ; -- exit code
+1 DO EN^XBVK("APCH")
+2 QUIT
+3 ;
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("APCHTPD",$JOB,0),U)+1
SET $PIECE(^TMP("APCHTPD",$JOB,0),U)=%
+2 SET ^TMP("APCHTPD",$JOB,%,0)=X
+3 QUIT
