APCHMT3 ; IHS/CMI/LAB -- health summary create/modify ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;; ;
;routine to create/modify a health summary type
;
BACK ;go back to listman
D TERM^VALM0
S VALMBCK="R"
D INIT
D HDR
K DIR
K X,Y,Z,I
Q
COMP(S,C) ;EP
NEW X,Y S Y=0,X=0 F S X=$O(^APCHSCTL(S,1,X)) Q:X'=+X!(Y) I $P(^APCHSCTL(S,1,X,0),U,2)=C S Y=1
Q Y
TP ;EP - called from protocol entry
D FULL^VALM1
I '$$COMP(APCHDA,$O(^APCHSCMP("B","BEST PRACTICE PROMPTS",0))) W !!,"WARNING: Best Practice Prompts has not been added to the Health Summary",! D
.W "structure. Best Practice Prompts will not display until they are part of the",!,"summary structure."
.S DIR(0)="E",DIR("A")="Press enter to continue" KILL DA D ^DIR KILL DIR
;
;
EN ; -- main entry point for E
D EN^VALM("APCH TP EDIT")
D BACK
Q
;
ADD ;add individual reminders or remove
D FULL^VALM1
W !!,"Enter the sequence number to put this Best Practice Prompt and then enter",!,"the prompt by name.",!
K DIE S DA=APCHDA,DIE="^APCHSCTL(",DR=13 D ^DIE K DIE,DIV,DIW
D BACK
Q
REM ;
D FULL^VALM1
S APCHSEQ=$$READ("N^0:999:","Enter the sequence number of the Best Practice Prompt to remove")
I APCHSEQ="" Q
I APCHSEQ="^" Q
K DIRUT
I '$D(^APCHSCTL(APCHDA,13,APCHSEQ,0)) W !!,"Invalid Sequence number." G REM
K ^APCHSCTL(APCHDA,13,APCHSEQ) S $P(^APCHSCTL(APCHDA,13,0),U,3)=APCHSEQ,$P(^APCHSCTL(APCHDA,13,0),U,4)=$P(^APCHSCTL(APCHDA,13,0),U,4)+1
D BACK
Q
ADDG ;add reminders by group
D FULL^VALM1
W !!
S DIC="^APCHHMC(",DIC(0)="AEMQ",DIC("A")="Select the Category/Group of Best Practice Prompts to ADD: " D ^DIC K DIC
I Y=-1 Q
S APCHCAT=+Y
;add group
S APCHSEQ=$$READ("N^0:999:","Enter the sequence number to place this group of Best Practice Prompts")
I APCHSEQ="^" Q
I APCHSEQ="" Q
;now gather up all reminder of this category and put them in
;if number already exists then move all numbers down
D REMOVEG
W !!,"Adding all Best Practice Prompts in the ",$P(^APCHHMC(APCHCAT,0),U)," group."
K APCHC S X=0 F S X=$O(^APCHSCTL(APCHDA,13,X)) Q:X'=+X S APCHC($P(^APCHSCTL(APCHDA,13,X,0),U))=$P(^APCHSCTL(APCHDA,13,X,0),U,2)
K ^APCHSCTL(APCHDA,13) S ^APCHSCTL(APCHDA,13,0)="^9001015.06AI^0^0"
S (B,C,X)=0 F S X=$O(APCHC(X)) Q:X'=+X!(X>APCHSEQ)!(X=APCHSEQ) S ^APCHSCTL(APCHDA,13,X,0)=X_U_APCHC(X),C=C+1,$P(^APCHSCTL(APCHDA,13,0),U,3)=X,$P(^APCHSCTL(APCHDA,13,0),U,4)=C,B=X K APCHC(X)
;now put in new ones
S Z=B S Y=0 F S Y=$O(^APCHSURV(Y)) Q:Y'=+Y I $P(^APCHSURV(Y,0),U,5)=APCHCAT,$P(^APCHSURV(Y,0),U,7)="T" S Z=Z+5,C=C+1 S ^APCHSCTL(APCHDA,13,Z,0)=Z_U_Y,$P(^APCHSCTL(APCHDA,13,0),U,3)=Z,$P(^APCHSCTL(APCHDA,13,0),U,4)=C
;now remaining old ones
S X=0 F S X=$O(APCHC(X)) Q:X'=+X S Z=Z+5,C=C+1 S ^APCHSCTL(APCHDA,13,Z,0)=Z_U_APCHC(X),$P(^APCHSCTL(APCHDA,13,0),U,3)=Z,$P(^APCHSCTL(APCHDA,13,0),U,4)=C
D BACK
Q
REMOVEG ;
I $G(APCHTALK) W !!,"Removing all Best Practice Prompts in the ",$P(^APCHHMC(APCHCAT,0),U)," group."
S X=0 F S X=$O(^APCHSCTL(APCHDA,13,X)) Q:X'=+X D
.S Y=$P(^APCHSCTL(APCHDA,13,X,0),U,2)
.I $P(^APCHSURV(Y,0),U,5)=APCHCAT K ^APCHSCTL(APCHDA,13,X,0)
.Q
Q
REMG ;ep
D FULL^VALM1
W !!
S DIC="^APCHHMC(",DIC(0)="AEMQ",DIC("A")="Select the Category of Best Practice Prompts to REMOVE: " D ^DIC K DIC
I Y=-1 Q
S APCHCAT=+Y
S APCHTALK=1 D REMOVEG K APCHTALK
D BACK
Q
;
HDR ; -- header code
S VALMHDR(1)="Health Summary: "_$P(^APCHSCTL(APCHDA,0),U)
Q
;
INIT ; -- init variables and list array
K ^TMP($J,"APCHHMRT") S APCHC=0 K APCHT
S X="Note: any Best Practice Prompt flagged as inactive will not display" D S(X)
S X=" on the summary even though you selected it for display. The " D S(X)
S X=" Best Practice Prompt must be activated. Any Best Practice Prompts" D S(X)
S X=" with (DEL) should be removed as they are no longer used." D S(X)
S X="Currently defined BEST PRACTICE PROMPTS on the "_$P(^APCHSCTL(APCHDA,0),U)_" summary type" D S(X,1)
S X="",$E(X,5)="SEQ",$E(X,10)="Best Practice Prompts",$E(X,65)="Category/Group" D S(X,1)
S X="-------------------------------------------------------------------------------" D S(X)
S Y=0,T=0 F S Y=$O(^APCHSCTL(APCHDA,13,Y)) Q:Y'=+Y D
.S T=T+1 S O=$P(^APCHSCTL(APCHDA,13,Y,0),U),C=$P(^APCHSCTL(APCHDA,13,Y,0),U,2),N=$P($G(^APCHSURV(+C,0)),U,1)
.S X="",$E(X,5)=O,$E(X,10)=N_" "_$S($P(^APCHSURV(C,0),U,3)="I":"(INACT)",$P(^APCHSURV(C,0),U,3)="D":"(DEL)",1:"")
.S $E(X,65)=$$VAL^XBDIQ1(9001018,C,.05) D S(X)
.S APCHT(C)=""
;now get all those that aren't yet used
S X="Other BEST PRACTICE PROMPTS not yet selected that can be " D S(X,2)
S X="added to this summary type:" D S(X)
S T=0 F S T=$O(^APCHSURV(T)) Q:T'=+T D
.Q:$D(APCHT(T)) ;already used
.Q:$P(^APCHSURV(T,0),U,3)="D"
.Q:$P(^APCHSURV(T,0),U,7)'="T"
.S X="",$E(X,7)=$P(^APCHSURV(T,0),U),$E(X,65)=$$VAL^XBDIQ1(9001018,T,.05) D S(X)
S VALMCNT=$O(^TMP($J,"APCHHMRT",""),-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,"APCHHMRT",APCHC,0)=X
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- EXIT code
Q
;
EXPND ; -- expand code
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
APCHMT3 ; IHS/CMI/LAB -- health summary create/modify ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+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
+4 DO HDR
+5 KILL DIR
+6 KILL X,Y,Z,I
+7 QUIT
COMP(S,C) ;EP
+1 NEW X,Y
SET Y=0
SET X=0
FOR
SET X=$ORDER(^APCHSCTL(S,1,X))
IF X'=+X!(Y)
QUIT
IF $PIECE(^APCHSCTL(S,1,X,0),U,2)=C
SET Y=1
+2 QUIT Y
TP ;EP - called from protocol entry
+1 DO FULL^VALM1
+2 IF '$$COMP(APCHDA,$ORDER(^APCHSCMP("B","BEST PRACTICE PROMPTS",0)))
WRITE !!,"WARNING: Best Practice Prompts has not been added to the Health Summary",!
Begin DoDot:1
+3 WRITE "structure. Best Practice Prompts will not display until they are part of the",!,"summary structure."
+4 SET DIR(0)="E"
SET DIR("A")="Press enter to continue"
KILL DA
DO ^DIR
KILL DIR
End DoDot:1
+5 ;
+6 ;
EN ; -- main entry point for E
+1 DO EN^VALM("APCH TP EDIT")
+2 DO BACK
+3 QUIT
+4 ;
ADD ;add individual reminders or remove
+1 DO FULL^VALM1
+2 WRITE !!,"Enter the sequence number to put this Best Practice Prompt and then enter",!,"the prompt by name.",!
+3 KILL DIE
SET DA=APCHDA
SET DIE="^APCHSCTL("
SET DR=13
DO ^DIE
KILL DIE,DIV,DIW
+4 DO BACK
+5 QUIT
REM ;
+1 DO FULL^VALM1
+2 SET APCHSEQ=$$READ("N^0:999:","Enter the sequence number of the Best Practice Prompt to remove")
+3 IF APCHSEQ=""
QUIT
+4 IF APCHSEQ="^"
QUIT
+5 KILL DIRUT
+6 IF '$DATA(^APCHSCTL(APCHDA,13,APCHSEQ,0))
WRITE !!,"Invalid Sequence number."
GOTO REM
+7 KILL ^APCHSCTL(APCHDA,13,APCHSEQ)
SET $PIECE(^APCHSCTL(APCHDA,13,0),U,3)=APCHSEQ
SET $PIECE(^APCHSCTL(APCHDA,13,0),U,4)=$PIECE(^APCHSCTL(APCHDA,13,0),U,4)+1
+8 DO BACK
+9 QUIT
ADDG ;add reminders by group
+1 DO FULL^VALM1
+2 WRITE !!
+3 SET DIC="^APCHHMC("
SET DIC(0)="AEMQ"
SET DIC("A")="Select the Category/Group of Best Practice Prompts to ADD: "
DO ^DIC
KILL DIC
+4 IF Y=-1
QUIT
+5 SET APCHCAT=+Y
+6 ;add group
+7 SET APCHSEQ=$$READ("N^0:999:","Enter the sequence number to place this group of Best Practice Prompts")
+8 IF APCHSEQ="^"
QUIT
+9 IF APCHSEQ=""
QUIT
+10 ;now gather up all reminder of this category and put them in
+11 ;if number already exists then move all numbers down
+12 DO REMOVEG
+13 WRITE !!,"Adding all Best Practice Prompts in the ",$PIECE(^APCHHMC(APCHCAT,0),U)," group."
+14 KILL APCHC
SET X=0
FOR
SET X=$ORDER(^APCHSCTL(APCHDA,13,X))
IF X'=+X
QUIT
SET APCHC($PIECE(^APCHSCTL(APCHDA,13,X,0),U))=$PIECE(^APCHSCTL(APCHDA,13,X,0),U,2)
+15 KILL ^APCHSCTL(APCHDA,13)
SET ^APCHSCTL(APCHDA,13,0)="^9001015.06AI^0^0"
+16 SET (B,C,X)=0
FOR
SET X=$ORDER(APCHC(X))
IF X'=+X!(X>APCHSEQ)!(X=APCHSEQ)
QUIT
SET ^APCHSCTL(APCHDA,13,X,0)=X_U_APCHC(X)
SET C=C+1
SET $PIECE(^APCHSCTL(APCHDA,13,0),U,3)=X
SET $PIECE(^APCHSCTL(APCHDA,13,0),U,4)=C
SET B=X
KILL APCHC(X)
+17 ;now put in new ones
+18 SET Z=B
SET Y=0
FOR
SET Y=$ORDER(^APCHSURV(Y))
IF Y'=+Y
QUIT
IF $PIECE(^APCHSURV(Y,0),U,5)=APCHCAT
IF $PIECE(^APCHSURV(Y,0),U,7)="T"
SET Z=Z+5
SET C=C+1
SET ^APCHSCTL(APCHDA,13,Z,0)=Z_U_Y
SET $PIECE(^APCHSCTL(APCHDA,13,0),U,3)=Z
SET $PIECE(^APCHSCTL(APCHDA,13,0),U,4)=C
+19 ;now remaining old ones
+20 SET X=0
FOR
SET X=$ORDER(APCHC(X))
IF X'=+X
QUIT
SET Z=Z+5
SET C=C+1
SET ^APCHSCTL(APCHDA,13,Z,0)=Z_U_APCHC(X)
SET $PIECE(^APCHSCTL(APCHDA,13,0),U,3)=Z
SET $PIECE(^APCHSCTL(APCHDA,13,0),U,4)=C
+21 DO BACK
+22 QUIT
REMOVEG ;
+1 IF $GET(APCHTALK)
WRITE !!,"Removing all Best Practice Prompts in the ",$PIECE(^APCHHMC(APCHCAT,0),U)," group."
+2 SET X=0
FOR
SET X=$ORDER(^APCHSCTL(APCHDA,13,X))
IF X'=+X
QUIT
Begin DoDot:1
+3 SET Y=$PIECE(^APCHSCTL(APCHDA,13,X,0),U,2)
+4 IF $PIECE(^APCHSURV(Y,0),U,5)=APCHCAT
KILL ^APCHSCTL(APCHDA,13,X,0)
+5 QUIT
End DoDot:1
+6 QUIT
REMG ;ep
+1 DO FULL^VALM1
+2 WRITE !!
+3 SET DIC="^APCHHMC("
SET DIC(0)="AEMQ"
SET DIC("A")="Select the Category of Best Practice Prompts to REMOVE: "
DO ^DIC
KILL DIC
+4 IF Y=-1
QUIT
+5 SET APCHCAT=+Y
+6 SET APCHTALK=1
DO REMOVEG
KILL APCHTALK
+7 DO BACK
+8 QUIT
+9 ;
HDR ; -- header code
+1 SET VALMHDR(1)="Health Summary: "_$PIECE(^APCHSCTL(APCHDA,0),U)
+2 QUIT
+3 ;
INIT ; -- init variables and list array
+1 KILL ^TMP($JOB,"APCHHMRT")
SET APCHC=0
KILL APCHT
+2 SET X="Note: any Best Practice Prompt flagged as inactive will not display"
DO S(X)
+3 SET X=" on the summary even though you selected it for display. The "
DO S(X)
+4 SET X=" Best Practice Prompt must be activated. Any Best Practice Prompts"
DO S(X)
+5 SET X=" with (DEL) should be removed as they are no longer used."
DO S(X)
+6 SET X="Currently defined BEST PRACTICE PROMPTS on the "_$PIECE(^APCHSCTL(APCHDA,0),U)_" summary type"
DO S(X,1)
+7 SET X=""
SET $EXTRACT(X,5)="SEQ"
SET $EXTRACT(X,10)="Best Practice Prompts"
SET $EXTRACT(X,65)="Category/Group"
DO S(X,1)
+8 SET X="-------------------------------------------------------------------------------"
DO S(X)
+9 SET Y=0
SET T=0
FOR
SET Y=$ORDER(^APCHSCTL(APCHDA,13,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+10 SET T=T+1
SET O=$PIECE(^APCHSCTL(APCHDA,13,Y,0),U)
SET C=$PIECE(^APCHSCTL(APCHDA,13,Y,0),U,2)
SET N=$PIECE($GET(^APCHSURV(+C,0)),U,1)
+11 SET X=""
SET $EXTRACT(X,5)=O
SET $EXTRACT(X,10)=N_" "_$SELECT($PIECE(^APCHSURV(C,0),U,3)="I":"(INACT)",$PIECE(^APCHSURV(C,0),U,3)="D":"(DEL)",1:"")
+12 SET $EXTRACT(X,65)=$$VAL^XBDIQ1(9001018,C,.05)
DO S(X)
+13 SET APCHT(C)=""
End DoDot:1
+14 ;now get all those that aren't yet used
+15 SET X="Other BEST PRACTICE PROMPTS not yet selected that can be "
DO S(X,2)
+16 SET X="added to this summary type:"
DO S(X)
+17 SET T=0
FOR
SET T=$ORDER(^APCHSURV(T))
IF T'=+T
QUIT
Begin DoDot:1
+18 ;already used
IF $DATA(APCHT(T))
QUIT
+19 IF $PIECE(^APCHSURV(T,0),U,3)="D"
QUIT
+20 IF $PIECE(^APCHSURV(T,0),U,7)'="T"
QUIT
+21 SET X=""
SET $EXTRACT(X,7)=$PIECE(^APCHSURV(T,0),U)
SET $EXTRACT(X,65)=$$VAL^XBDIQ1(9001018,T,.05)
DO S(X)
End DoDot:1
+22 SET VALMCNT=$ORDER(^TMP($JOB,"APCHHMRT",""),-1)
+23 QUIT
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,"APCHHMRT",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 ;
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
