- 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