APCHPWHT ; IHS/CMI/LAB -- create/modify health summary type ; 06 Sep 2011 1:08 PM
;;2.0;IHS PCC SUITE;**6,7,11**;MAY 14, 2009;Build 58
;; ;
;routine to create/modify a health summary type
EP ;EP - called from option
W !!!,"This option will allow you to create a new or modify an existing"
W !,"Patient Wellness Handout type.",!!
D ^XBFMK S DIC="^APCHPWHT(",DIC(0)="AEMQL" D ^DIC K DIC,DA,DR,DD,DO
I Y=-1 W !!,"Goodbye",! D EOJ Q
S %=$P(^APCHPWHT(+Y,0),U,2) I %]"",$D(^XUSEC(%,DUZ))[0 W !,"This Patient Wellness handout type is currently locked to prevent alteration.",! G EP
S APCHPWHT=+Y
S DIE="^APCHPWHT(",DA=APCHPWHT,DR=".01;.03" D ^DIE D ^XBFMK
D EN
EOJ ;
D EN^XBVK("APCH")
D ^XBFMK
Q
EN ; -- main entry point for APCH CREATE/MODIFY TYPE
D EN^VALM("APCH PWH CREATE/MODIFY TYPE")
D CLEAR^VALM1
D FULL^VALM1
W:$D(IOF) @IOF
D EOJ
Q
;
HDR ;EP -- header code
S VALMHDR(1)="Patient Wellness Handout: " I $G(APCHPWHT),$D(^APCHPWHT(APCHPWHT)) S VALMHDR(1)=VALMHDR(1)_$P(^APCHPWHT(APCHPWHT,0),U)
Q
;
INIT ;EP -- init variables and list array
K ^TMP($J,"APCHTYPE")
S APCHC=0
NEW X,Y,O,C,M,T,A,I,V,W,B,E
S A="",T="",I="",B="",E=""
S X="STRUCTURE: " D S(X)
S X="Order",$E(X,7)="Component" D S(X)
S Y=0 F S Y=$O(^APCHPWHT(APCHPWHT,1,Y)) Q:Y'=+Y D
.S A="",T="",I="",B="",E="",O=$P(^APCHPWHT(APCHPWHT,1,Y,0),U),C=$P(^APCHPWHT(APCHPWHT,1,Y,0),U,2),C=$P($G(^APCHPWHC(+C,0)),U,1)
.I C="ALLERGIES" S A=Y
.I C["TRANSPAR" S T=Y
.I C["RECENT LAB" S B=Y
.I C["INTAKE" S I=Y
.I C["EDUCATION HANDOUT" S E=Y
.S X=O,$E(X,7)=C D S(X) ;,$E(X,49)=M,$E(X,57)=T,$E(X,62)=A D S(X)
.I A K Z S X="Source for Allergy component: " D ENPM^XBDIQ1(9001026.01,APCHPWHT_",0",".03","Z(") S X=X_$G(Z(A,.03)) D S(X)
.I B K Z S X="Display Comments with Lab component: " D ENPM^XBDIQ1(9001026.01,APCHPWHT_",0",".04","Z(") S X=X_$G(Z(B,.04)) D S(X)
.I T D
..D S(" Measures:")
..S V=0 F S V=$O(^APCHPWHT(APCHPWHT,1,T,11,V)) Q:V'=+V D
...S W=$P(^APCHPWHT(APCHPWHT,1,T,11,V,0),U,2)
...I W S W=$P(^APCHPWHE(W,0),U,1)
...S X="",$E(X,8)=V,$E(X,12)=W D S(X)
.I I D
..D S(" Intake Forms:")
..S V=0 F S V=$O(^APCHPWHT(APCHPWHT,1,I,12,V)) Q:V'=+V D
...S W=$P(^APCHPWHT(APCHPWHT,1,I,12,V,0),U,2)
...I W S W=$P(^APCHPWHF(W,0),U,1)
...S X="",$E(X,8)=V,$E(X,12)=W D S(X)
.I E D
..D S(" Education Handouts:")
..S V=0 F S V=$O(^APCHPWHT(APCHPWHT,1,E,13,V)) Q:V'=+V D
...S W=$P(^APCHPWHT(APCHPWHT,1,E,13,V,0),U,2)
...I W S W=$P(^APCHPWHF(W,0),U,1)
...S X="",$E(X,8)=V,$E(X,12)=W D S(X)
C ;
S VALMCNT=$O(^TMP($J,"APCHTYPE",""),-1)
Q
;
S(Y,F,C,T) ;EP - 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 APCHC=APCHC+1
S ^TMP($J,"APCHTYPE",APCHC,0)=X
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- EXIT code
Q
;
EXPND ; -- expand code
Q
;
;routine to create/modify a health summary type
;
BACK ;go back to listman
D TERM^VALM0
S VALMBCK="R"
D INIT^APCHPWHT
D HDR^APCHPWHT
K DIR
K X,Y,Z,I
Q
;
COMP(S,C) ;EP
NEW X,Y S Y=0,X=0 F S X=$O(^APCHPWHT(S,1,X)) Q:X'=+X!(Y) I $P(^APCHPWHT(S,1,X,0),U,2)=C S Y=1
Q Y
;
DH ;EP called from protocol to generate PWH
D FULL^VALM1
S DFN=""
S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC,DA,DR,DLAYGO,DIADD
I Y<0 W !,"No Patient Selected." D BACK Q
S DFN=+Y
S Y=DFN D ^AUPNPAT
S APCHSDFN=DFN
S %=$P(^APCHPWHT(APCHPWHT,0),U)_" Patient Wellness Handout for "_$P(^DPT(APCHSDFN,0),U)
D VIEWR^XBLM("EN1^APCHPWHG(APCHPWHT)",%)
D BACK
Q
;
PH ;EP called from protocol to generate PWH
D FULL^VALM1
S DFN=""
S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC,DA,DR,DLAYGO,DIADD
I Y<0 W !,"No Patient Selected." D BACK Q
S DFN=+Y
S Y=DFN D ^AUPNPAT
S APCHSDFN=DFN
S %=$P(^APCHPWHT(APCHPWHT,0),U)_" Patient Wellness Handout for "_$P(^DPT(APCHSDFN,0),U)
S APCHITST=1
D EN2^APCHPWHG(APCHPWHT,DFN)
K APCHITST
D BACK
Q
;
AS ;EP
D FULL^VALM1
I '$$ALG(APCHPWHT) W !!,"You have not added Allergies as a component to this Patient Wellness Handout",!,"type. Don't forget to do so.",!
S DA=APCHPWHT,DIE="^APCHPWHT(",DR=".04" D ^DIE,^XBFMK
D BACK
Q
;
CCIP ;EP - called from protocol entry
D FULL^VALM1
I '$$COMP(APCHPWHT,$O(^APCHPWHC("B","CCI MEASURES",0))) W !!,"WARNING: CCI MEASURES has not been added to the Handout Structure.",!,"CCI MEASURES will not display until they are part of the handout",!,"structure."
W !!,"You can add a new CCI Measure by entering a new sequence number",!,"and CCI Measure name. To remove a CCI Measure from this handout type select the measure",!
W "by sequence number and type an '@',",!
S DA=APCHPWHT,DIE="^APCHPWHT(",DR=12 D ^DIE,^XBFMK
D BACK
Q
;
TQMP ;EP - called from protocol entry
D FULL^VALM1
I '$$COMP(APCHPWHT,$O(^APCHPWHC("B","QUALITY OF CARE TRANSPARENCY R",0))) D
.W !!,"WARNING: QUALITY OF CARE TRANSPARENCY REPORT CARD has not been added to the ",!,"Handout Structure.",!,"Quality Transparency MEASURES will not display until they are part of the",!," handout structure."
W !!,"You can add a new Quality of Care Transparency Measure by entering a ",!,"new sequence number and measure name. ",!,"To remove a Measure from this handout type select the measure",!
W "by sequence number and type an '@',",!
S DA=APCHPWHT,DIE="^APCHPWHT(",DR=11 D ^DIE,^XBFMK
D BACK
Q
;
MS ;EP - called from protocol entry
D FULL^VALM1
W !!,"You can add a new component by entering a new order number and",!,"component name. To remove a component from this PWH type select the",!,"component by name or order and then enter an '@'.",!
S DA=APCHPWHT,DIE="^APCHPWHT(",DR="[APCH MODIFY TYPE]" D ^DIE,^XBFMK
D BACK
Q
PAUSE ;EP; -- ask user to press ENTER
Q:IOST'["C-"
NEW Y S Y=$$READ("E","Press ENTER to continue") D ^XBCLS Q
READ(TYPE,PROMPT,DEFAULT,HELP,SCREEN,DIRA) ;EP; calls reader, returns response
NEW DIR,X,Y
S DIR(0)=TYPE
I $D(SCREEN) S DIR("S")=SCREEN
I $G(PROMPT)]"" S DIR("A")=PROMPT
I $G(DEFAULT)]"" S DIR("B")=DEFAULT
I $D(HELP) S DIR("?")=HELP
I $D(DIRA(1)) S Y=0 F S Y=$O(DIRA(Y)) Q:Y="" S DIR("A",Y)=DIRA(Y)
D ^DIR
Q Y
;
ALG(P) ;
NEW A,B,G
S G=""
S A=0 F S A=$O(^APCHPWHT(P,1,A)) Q:A'=+A S B=$P(^APCHPWHT(P,1,A,0),U,2),B=$P(^APCHPWHC(+B,0),U) I B["ALLERG" S G=1
Q G
;
CCI(P) ;
NEW A,B,G
S G=""
S A=0 F S A=$O(^APCHPWHT(P,1,A)) Q:A'=+A S B=$P(^APCHPWHT(P,1,A,0),U,2),B=$P(^APCHPWHC(+B,0),U) I B["CCI" S G=1
Q G
;
TQM(P) ;
NEW A,B,G
S G=""
S A=0 F S A=$O(^APCHPWHT(P,1,A)) Q:A'=+A S B=$P(^APCHPWHT(P,1,A,0),U,2),B=$P(^APCHPWHC(+B,0),U) I B["TRANSPAR" S G=1
Q G
;
APCHPWHT ; IHS/CMI/LAB -- create/modify health summary type ; 06 Sep 2011 1:08 PM
+1 ;;2.0;IHS PCC SUITE;**6,7,11**;MAY 14, 2009;Build 58
+2 ;; ;
+3 ;routine to create/modify a health summary type
EP ;EP - called from option
+1 WRITE !!!,"This option will allow you to create a new or modify an existing"
+2 WRITE !,"Patient Wellness Handout type.",!!
+3 DO ^XBFMK
SET DIC="^APCHPWHT("
SET DIC(0)="AEMQL"
DO ^DIC
KILL DIC,DA,DR,DD,DO
+4 IF Y=-1
WRITE !!,"Goodbye",!
DO EOJ
QUIT
+5 SET %=$PIECE(^APCHPWHT(+Y,0),U,2)
IF %]""
IF $DATA(^XUSEC(%,DUZ))[0
WRITE !,"This Patient Wellness handout type is currently locked to prevent alteration.",!
GOTO EP
+6 SET APCHPWHT=+Y
+7 SET DIE="^APCHPWHT("
SET DA=APCHPWHT
SET DR=".01;.03"
DO ^DIE
DO ^XBFMK
+8 DO EN
EOJ ;
+1 DO EN^XBVK("APCH")
+2 DO ^XBFMK
+3 QUIT
EN ; -- main entry point for APCH CREATE/MODIFY TYPE
+1 DO EN^VALM("APCH PWH CREATE/MODIFY TYPE")
+2 DO CLEAR^VALM1
+3 DO FULL^VALM1
+4 IF $DATA(IOF)
WRITE @IOF
+5 DO EOJ
+6 QUIT
+7 ;
HDR ;EP -- header code
+1 SET VALMHDR(1)="Patient Wellness Handout: "
IF $GET(APCHPWHT)
IF $DATA(^APCHPWHT(APCHPWHT))
SET VALMHDR(1)=VALMHDR(1)_$PIECE(^APCHPWHT(APCHPWHT,0),U)
+2 QUIT
+3 ;
INIT ;EP -- init variables and list array
+1 KILL ^TMP($JOB,"APCHTYPE")
+2 SET APCHC=0
+3 NEW X,Y,O,C,M,T,A,I,V,W,B,E
+4 SET A=""
SET T=""
SET I=""
SET B=""
SET E=""
+5 SET X="STRUCTURE: "
DO S(X)
+6 SET X="Order"
SET $EXTRACT(X,7)="Component"
DO S(X)
+7 SET Y=0
FOR
SET Y=$ORDER(^APCHPWHT(APCHPWHT,1,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+8 SET A=""
SET T=""
SET I=""
SET B=""
SET E=""
SET O=$PIECE(^APCHPWHT(APCHPWHT,1,Y,0),U)
SET C=$PIECE(^APCHPWHT(APCHPWHT,1,Y,0),U,2)
SET C=$PIECE($GET(^APCHPWHC(+C,0)),U,1)
+9 IF C="ALLERGIES"
SET A=Y
+10 IF C["TRANSPAR"
SET T=Y
+11 IF C["RECENT LAB"
SET B=Y
+12 IF C["INTAKE"
SET I=Y
+13 IF C["EDUCATION HANDOUT"
SET E=Y
+14 ;,$E(X,49)=M,$E(X,57)=T,$E(X,62)=A D S(X)
SET X=O
SET $EXTRACT(X,7)=C
DO S(X)
+15 IF A
KILL Z
SET X="Source for Allergy component: "
DO ENPM^XBDIQ1(9001026.01,APCHPWHT_",0",".03","Z(")
SET X=X_$GET(Z(A,.03))
DO S(X)
+16 IF B
KILL Z
SET X="Display Comments with Lab component: "
DO ENPM^XBDIQ1(9001026.01,APCHPWHT_",0",".04","Z(")
SET X=X_$GET(Z(B,.04))
DO S(X)
+17 IF T
Begin DoDot:2
+18 DO S(" Measures:")
+19 SET V=0
FOR
SET V=$ORDER(^APCHPWHT(APCHPWHT,1,T,11,V))
IF V'=+V
QUIT
Begin DoDot:3
+20 SET W=$PIECE(^APCHPWHT(APCHPWHT,1,T,11,V,0),U,2)
+21 IF W
SET W=$PIECE(^APCHPWHE(W,0),U,1)
+22 SET X=""
SET $EXTRACT(X,8)=V
SET $EXTRACT(X,12)=W
DO S(X)
End DoDot:3
End DoDot:2
+23 IF I
Begin DoDot:2
+24 DO S(" Intake Forms:")
+25 SET V=0
FOR
SET V=$ORDER(^APCHPWHT(APCHPWHT,1,I,12,V))
IF V'=+V
QUIT
Begin DoDot:3
+26 SET W=$PIECE(^APCHPWHT(APCHPWHT,1,I,12,V,0),U,2)
+27 IF W
SET W=$PIECE(^APCHPWHF(W,0),U,1)
+28 SET X=""
SET $EXTRACT(X,8)=V
SET $EXTRACT(X,12)=W
DO S(X)
End DoDot:3
End DoDot:2
+29 IF E
Begin DoDot:2
+30 DO S(" Education Handouts:")
+31 SET V=0
FOR
SET V=$ORDER(^APCHPWHT(APCHPWHT,1,E,13,V))
IF V'=+V
QUIT
Begin DoDot:3
+32 SET W=$PIECE(^APCHPWHT(APCHPWHT,1,E,13,V,0),U,2)
+33 IF W
SET W=$PIECE(^APCHPWHF(W,0),U,1)
+34 SET X=""
SET $EXTRACT(X,8)=V
SET $EXTRACT(X,12)=W
DO S(X)
End DoDot:3
End DoDot:2
End DoDot:1
C ;
+1 SET VALMCNT=$ORDER(^TMP($JOB,"APCHTYPE",""),-1)
+2 QUIT
+3 ;
S(Y,F,C,T) ;EP - 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 APCHC=APCHC+1
+2 SET ^TMP($JOB,"APCHTYPE",APCHC,0)=X
+3 QUIT
+4 ;
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 ;
+3 ;routine to create/modify a health summary type
+4 ;
BACK ;go back to listman
+1 DO TERM^VALM0
+2 SET VALMBCK="R"
+3 DO INIT^APCHPWHT
+4 DO HDR^APCHPWHT
+5 KILL DIR
+6 KILL X,Y,Z,I
+7 QUIT
+8 ;
COMP(S,C) ;EP
+1 NEW X,Y
SET Y=0
SET X=0
FOR
SET X=$ORDER(^APCHPWHT(S,1,X))
IF X'=+X!(Y)
QUIT
IF $PIECE(^APCHPWHT(S,1,X,0),U,2)=C
SET Y=1
+2 QUIT Y
+3 ;
DH ;EP called from protocol to generate PWH
+1 DO FULL^VALM1
+2 SET DFN=""
+3 SET DIC="^AUPNPAT("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC,DA,DR,DLAYGO,DIADD
+4 IF Y<0
WRITE !,"No Patient Selected."
DO BACK
QUIT
+5 SET DFN=+Y
+6 SET Y=DFN
DO ^AUPNPAT
+7 SET APCHSDFN=DFN
+8 SET %=$PIECE(^APCHPWHT(APCHPWHT,0),U)_" Patient Wellness Handout for "_$PIECE(^DPT(APCHSDFN,0),U)
+9 DO VIEWR^XBLM("EN1^APCHPWHG(APCHPWHT)",%)
+10 DO BACK
+11 QUIT
+12 ;
PH ;EP called from protocol to generate PWH
+1 DO FULL^VALM1
+2 SET DFN=""
+3 SET DIC="^AUPNPAT("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC,DA,DR,DLAYGO,DIADD
+4 IF Y<0
WRITE !,"No Patient Selected."
DO BACK
QUIT
+5 SET DFN=+Y
+6 SET Y=DFN
DO ^AUPNPAT
+7 SET APCHSDFN=DFN
+8 SET %=$PIECE(^APCHPWHT(APCHPWHT,0),U)_" Patient Wellness Handout for "_$PIECE(^DPT(APCHSDFN,0),U)
+9 SET APCHITST=1
+10 DO EN2^APCHPWHG(APCHPWHT,DFN)
+11 KILL APCHITST
+12 DO BACK
+13 QUIT
+14 ;
AS ;EP
+1 DO FULL^VALM1
+2 IF '$$ALG(APCHPWHT)
WRITE !!,"You have not added Allergies as a component to this Patient Wellness Handout",!,"type. Don't forget to do so.",!
+3 SET DA=APCHPWHT
SET DIE="^APCHPWHT("
SET DR=".04"
DO ^DIE
DO ^XBFMK
+4 DO BACK
+5 QUIT
+6 ;
CCIP ;EP - called from protocol entry
+1 DO FULL^VALM1
+2 IF '$$COMP(APCHPWHT,$ORDER(^APCHPWHC("B","CCI MEASURES",0)))
WRITE !!,"WARNING: CCI MEASURES has not been added to the Handout Structure.",!,"CCI MEASURES will not display until they are part of the handout",!,"structure."
+3 WRITE !!,"You can add a new CCI Measure by entering a new sequence number",!,"and CCI Measure name. To remove a CCI Measure from this handout type select the measure",!
+4 WRITE "by sequence number and type an '@',",!
+5 SET DA=APCHPWHT
SET DIE="^APCHPWHT("
SET DR=12
DO ^DIE
DO ^XBFMK
+6 DO BACK
+7 QUIT
+8 ;
TQMP ;EP - called from protocol entry
+1 DO FULL^VALM1
+2 IF '$$COMP(APCHPWHT,$ORDER(^APCHPWHC("B","QUALITY OF CARE TRANSPARENCY R",0)))
Begin DoDot:1
+3 WRITE !!,"WARNING: QUALITY OF CARE TRANSPARENCY REPORT CARD has not been added to the ",!,"Handout Structure.",!,"Quality Transparency MEASURES will not display until they are part of the",!," handout structure."
End DoDot:1
+4 WRITE !!,"You can add a new Quality of Care Transparency Measure by entering a ",!,"new sequence number and measure name. ",!,"To remove a Measure from this handout type select the measure",!
+5 WRITE "by sequence number and type an '@',",!
+6 SET DA=APCHPWHT
SET DIE="^APCHPWHT("
SET DR=11
DO ^DIE
DO ^XBFMK
+7 DO BACK
+8 QUIT
+9 ;
MS ;EP - called from protocol entry
+1 DO FULL^VALM1
+2 WRITE !!,"You can add a new component by entering a new order number and",!,"component name. To remove a component from this PWH type select the",!,"component by name or order and then enter an '@'.",!
+3 SET DA=APCHPWHT
SET DIE="^APCHPWHT("
SET DR="[APCH MODIFY TYPE]"
DO ^DIE
DO ^XBFMK
+4 DO BACK
+5 QUIT
PAUSE ;EP; -- ask user to press ENTER
+1 IF IOST'["C-"
QUIT
+2 NEW Y
SET Y=$$READ("E","Press ENTER to continue")
DO ^XBCLS
QUIT
READ(TYPE,PROMPT,DEFAULT,HELP,SCREEN,DIRA) ;EP; calls reader, returns response
+1 NEW DIR,X,Y
+2 SET DIR(0)=TYPE
+3 IF $DATA(SCREEN)
SET DIR("S")=SCREEN
+4 IF $GET(PROMPT)]""
SET DIR("A")=PROMPT
+5 IF $GET(DEFAULT)]""
SET DIR("B")=DEFAULT
+6 IF $DATA(HELP)
SET DIR("?")=HELP
+7 IF $DATA(DIRA(1))
SET Y=0
FOR
SET Y=$ORDER(DIRA(Y))
IF Y=""
QUIT
SET DIR("A",Y)=DIRA(Y)
+8 DO ^DIR
+9 QUIT Y
+10 ;
ALG(P) ;
+1 NEW A,B,G
+2 SET G=""
+3 SET A=0
FOR
SET A=$ORDER(^APCHPWHT(P,1,A))
IF A'=+A
QUIT
SET B=$PIECE(^APCHPWHT(P,1,A,0),U,2)
SET B=$PIECE(^APCHPWHC(+B,0),U)
IF B["ALLERG"
SET G=1
+4 QUIT G
+5 ;
CCI(P) ;
+1 NEW A,B,G
+2 SET G=""
+3 SET A=0
FOR
SET A=$ORDER(^APCHPWHT(P,1,A))
IF A'=+A
QUIT
SET B=$PIECE(^APCHPWHT(P,1,A,0),U,2)
SET B=$PIECE(^APCHPWHC(+B,0),U)
IF B["CCI"
SET G=1
+4 QUIT G
+5 ;
TQM(P) ;
+1 NEW A,B,G
+2 SET G=""
+3 SET A=0
FOR
SET A=$ORDER(^APCHPWHT(P,1,A))
IF A'=+A
QUIT
SET B=$PIECE(^APCHPWHT(P,1,A,0),U,2)
SET B=$PIECE(^APCHPWHC(+B,0),U)
IF B["TRANSPAR"
SET G=1
+4 QUIT G
+5 ;
