- APCHTP1 ; IHS/CMI/LAB - TP 1 ;
- ;;2.0;IHS PCC SUITE;**2,10**;MAY 14, 2009;Build 88
- ;
- ;
- EP ;EP - CALLED FROM OPTION
- D EN
- Q
- EOJ ;EP
- D EN^XBVK("APCH")
- Q
- ;; ;
- EN ; -- main entry point for APCH TP DISPLAY
- D EN^VALM("APCH TP DISPLAY")
- D CLEAR^VALM1
- D FULL^VALM1
- W:$D(IOF) @IOF
- D EOJ
- Q
- ;
- HDR ; -- header code
- S VALMHDR(1)="Best Practice Prompt Logic Display"
- Q
- ;
- INIT ; -- init variables and list array
- K APCHDISP,APCHSEL,APCHHIGH,APCHLIST,APCHCSEL
- S APCHHIGH=0,X=0,N="" F S N=$O(^APCHSURV("B",N)) Q:N="" S X=0 F S X=$O(^APCHSURV("B",N,X)) Q:X'=+X I $P(^APCHSURV(X,0),U,3)'="D",$P(^APCHSURV(X,0),U,7)="T" S APCHHIGH=APCHHIGH+1,APCHSEL(APCHHIGH)=X
- S APCHCUT=((APCHHIGH/3)+1)\1
- ;S APCHCUT=(APCHHIGH/3)\1
- S (C,I)=0,J=1,K=1 F S I=$O(APCHSEL(I)) Q:I'=+I!($D(APCHDISP(I))) D
- .S C=C+1,APCHLIST(C,0)=I_") "_$S($D(APCHCSEL(I)):"*",1:" ")_$E($P(^APCHSURV(APCHSEL(I),0),U),1,20) S APCHDISP(I)="",APCHLIST("IDX",C,C)=""
- .S J=I+APCHCUT I $D(APCHSEL(J)),'$D(APCHDISP(J)) S $E(APCHLIST(C,0),28)=J_") "_$S($D(APCHCSEL(J)):"*",1:" ")_$E($P(^APCHSURV(APCHSEL(J),0),U),1,20) S APCHDISP(J)=""
- .S K=J+APCHCUT I $D(APCHSEL(K)),'$D(APCHDISP(K)) S $E(APCHLIST(C,0),55)=K_") "_$S($D(APCHCSEL(K)):"*",1:" ")_$E($P(^APCHSURV(APCHSEL(K),0),U),1,20) S APCHDISP(K)=""
- K APCHDISP
- S VALMCNT=C
- Q
- ;
- HELP ; -- help code
- S X="?" D DISP^XQORM1 W !!
- Q
- ;
- EXIT ; -- exit code
- Q
- ;
- EXPND ; -- expand code
- Q
- ;
- BACK ;go back to listman
- D TERM^VALM0
- S VALMBCK="R"
- D INIT
- D HDR
- K DIR
- K X,Y,Z,I
- Q
- ;
- ADD ;EP - add an item to the selected list - called from a protocol
- W ! S DIR(0)="LO^1:"_APCHHIGH,DIR("A")="Which item(s)" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
- I Y="" W !,"No items selected." G ADDX
- I $D(DIRUT) W !,"No items selected." G ADDX
- D FULL^VALM1 W:$D(IOF) @IOF
- S APCHANS=Y,APCHC="" F APCHI=1:1 S APCHC=$P(APCHANS,",",APCHI) Q:APCHC="" S APCHCSEL(APCHC)=""
- D DISPLAY
- ADDX ;
- D BACK
- Q
- ADDALL ;
- F X=1:1:APCHHIGH S APCHCSEL(X)=""
- D DISPLAY
- D BACK
- Q
- ;
- DISPLAY ;gather in ^TMP and display
- K ^TMP("APCHTP1",$J)
- S ^TMP("APCHTP1",$J,0)=0
- S APCHC=0
- S APCHX=0 F S APCHX=$O(APCHCSEL(APCHX)) Q:APCHX'=+APCHX S APCHTP=APCHSEL(APCHX),Y="Best Practice Prompt:",$E(Y,24)=$P(^APCHSURV(APCHTP,0),U) S APCHC=APCHC+1 D S(Y,$S(APCHC=1:0,1:2)) D
- .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
- .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)
- .S X=$TR($J("",80)," ","*") D S(X,2)
- ;
- ;
- K ^TMP("APCHTP1",$J,0)
- D ARRAY^XBLM("^TMP(""APCHTP1"",$J,","BEST PRACTICE PROMPTS DESCRIPTIONS")
- 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("APCHTP1",$J,0),U)+1,$P(^TMP("APCHTP1",$J,0),U)=%
- S ^TMP("APCHTP1",$J,%,0)=X
- Q
- APCHTP1 ; IHS/CMI/LAB - TP 1 ;
- +1 ;;2.0;IHS PCC SUITE;**2,10**;MAY 14, 2009;Build 88
- +2 ;
- +3 ;
- EP ;EP - CALLED FROM OPTION
- +1 DO EN
- +2 QUIT
- EOJ ;EP
- +1 DO EN^XBVK("APCH")
- +2 QUIT
- +3 ;; ;
- EN ; -- main entry point for APCH TP DISPLAY
- +1 DO EN^VALM("APCH TP DISPLAY")
- +2 DO CLEAR^VALM1
- +3 DO FULL^VALM1
- +4 IF $DATA(IOF)
- WRITE @IOF
- +5 DO EOJ
- +6 QUIT
- +7 ;
- HDR ; -- header code
- +1 SET VALMHDR(1)="Best Practice Prompt Logic Display"
- +2 QUIT
- +3 ;
- INIT ; -- init variables and list array
- +1 KILL APCHDISP,APCHSEL,APCHHIGH,APCHLIST,APCHCSEL
- +2 SET APCHHIGH=0
- SET X=0
- SET N=""
- FOR
- SET N=$ORDER(^APCHSURV("B",N))
- IF N=""
- QUIT
- SET X=0
- FOR
- SET X=$ORDER(^APCHSURV("B",N,X))
- IF X'=+X
- QUIT
- IF $PIECE(^APCHSURV(X,0),U,3)'="D"
- IF $PIECE(^APCHSURV(X,0),U,7)="T"
- SET APCHHIGH=APCHHIGH+1
- SET APCHSEL(APCHHIGH)=X
- +3 SET APCHCUT=((APCHHIGH/3)+1)\1
- +4 ;S APCHCUT=(APCHHIGH/3)\1
- +5 SET (C,I)=0
- SET J=1
- SET K=1
- FOR
- SET I=$ORDER(APCHSEL(I))
- IF I'=+I!($DATA(APCHDISP(I)))
- QUIT
- Begin DoDot:1
- +6 SET C=C+1
- SET APCHLIST(C,0)=I_") "_$SELECT($DATA(APCHCSEL(I)):"*",1:" ")_$EXTRACT($PIECE(^APCHSURV(APCHSEL(I),0),U),1,20)
- SET APCHDISP(I)=""
- SET APCHLIST("IDX",C,C)=""
- +7 SET J=I+APCHCUT
- IF $DATA(APCHSEL(J))
- IF '$DATA(APCHDISP(J))
- SET $EXTRACT(APCHLIST(C,0),28)=J_") "_$SELECT($DATA(APCHCSEL(J)):"*",1:" ")_$EXTRACT($PIECE(^APCHSURV(APCHSEL(J),0),U),1,20)
- SET APCHDISP(J)=""
- +8 SET K=J+APCHCUT
- IF $DATA(APCHSEL(K))
- IF '$DATA(APCHDISP(K))
- SET $EXTRACT(APCHLIST(C,0),55)=K_") "_$SELECT($DATA(APCHCSEL(K)):"*",1:" ")_$EXTRACT($PIECE(^APCHSURV(APCHSEL(K),0),U),1,20)
- SET APCHDISP(K)=""
- End DoDot:1
- +9 KILL APCHDISP
- +10 SET VALMCNT=C
- +11 QUIT
- +12 ;
- HELP ; -- help code
- +1 SET X="?"
- DO DISP^XQORM1
- WRITE !!
- +2 QUIT
- +3 ;
- EXIT ; -- exit code
- +1 QUIT
- +2 ;
- EXPND ; -- expand code
- +1 QUIT
- +2 ;
- BACK ;go back to listman
- +1 DO TERM^VALM0
- +2 SET VALMBCK="R"
- +3 DO INIT
- +4 DO HDR
- +5 KILL DIR
- +6 KILL X,Y,Z,I
- +7 QUIT
- +8 ;
- ADD ;EP - add an item to the selected list - called from a protocol
- +1 WRITE !
- SET DIR(0)="LO^1:"_APCHHIGH
- SET DIR("A")="Which item(s)"
- DO ^DIR
- KILL DIR
- IF $DATA(DUOUT)
- SET DIRUT=1
- +2 IF Y=""
- WRITE !,"No items selected."
- GOTO ADDX
- +3 IF $DATA(DIRUT)
- WRITE !,"No items selected."
- GOTO ADDX
- +4 DO FULL^VALM1
- IF $DATA(IOF)
- WRITE @IOF
- +5 SET APCHANS=Y
- SET APCHC=""
- FOR APCHI=1:1
- SET APCHC=$PIECE(APCHANS,",",APCHI)
- IF APCHC=""
- QUIT
- SET APCHCSEL(APCHC)=""
- +6 DO DISPLAY
- ADDX ;
- +1 DO BACK
- +2 QUIT
- ADDALL ;
- +1 FOR X=1:1:APCHHIGH
- SET APCHCSEL(X)=""
- +2 DO DISPLAY
- +3 DO BACK
- +4 QUIT
- +5 ;
- DISPLAY ;gather in ^TMP and display
- +1 KILL ^TMP("APCHTP1",$JOB)
- +2 SET ^TMP("APCHTP1",$JOB,0)=0
- +3 SET APCHC=0
- +4 SET APCHX=0
- FOR
- SET APCHX=$ORDER(APCHCSEL(APCHX))
- IF APCHX'=+APCHX
- QUIT
- SET APCHTP=APCHSEL(APCHX)
- SET Y="Best Practice Prompt:"
- SET $EXTRACT(Y,24)=$PIECE(^APCHSURV(APCHTP,0),U)
- SET APCHC=APCHC+1
- DO S(Y,$SELECT(APCHC=1:0,1:2))
- Begin DoDot: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 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:2
- +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":"UNKNOW
- N",1:"")
- +14 SET J=0
- FOR
- SET J=$ORDER(^APCHSURV(APCHTP,11,Y,11,J))
- IF J'=+J
- QUIT
- Begin DoDot:3
- +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)
- End DoDot:3
- +16 QUIT
- End DoDot:2
- +17 SET X="Currently defined on the following summary types:"
- DO S(X,1)
- +18 SET J=0
- FOR
- SET J=$ORDER(^APCHSCTL(J))
- IF J'=+J
- QUIT
- Begin DoDot:2
- +19 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)
- End DoDot:2
- +20 SET X=$TRANSLATE($JUSTIFY("",80)," ","*")
- DO S(X,2)
- End DoDot:1
- +21 ;
- +22 ;
- +23 KILL ^TMP("APCHTP1",$JOB,0)
- +24 DO ARRAY^XBLM("^TMP(""APCHTP1"",$J,","BEST PRACTICE PROMPTS DESCRIPTIONS")
- +25 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(^TMP("APCHTP1",$JOB,0),U)+1
- SET $PIECE(^TMP("APCHTP1",$JOB,0),U)=%
- +2 SET ^TMP("APCHTP1",$JOB,%,0)=X
- +3 QUIT