APCHTP1.m

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