- 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
