Routine: APCHTPP

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

XIT ;

 K J,K,X,Z,Y

 D EN^XBVK("APCH")

BROWSE ;

 S XBRP="VIEWR^XBLM(""PRINT^APCHTPP"")"

 S XBNS="APCH",XBRC="PROCESS^APCHTPP",XBRX="XIT^APCHTPP",XBIOP=0 D ^XBDBQUE

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)

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)

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

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

S1 ;

 S %=$P(^XTMP("APCHTPP",APCHJ,APCHH,0),U)+1,$P(^XTMP("APCHTPP",APCHJ,APCHH,0),U)=%

 S ^XTMP("APCHTPP",APCHJ,APCHH,%)=X

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)," ","-")

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

 ;----------

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       ;----------

APCHTPP.m