Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCHMT3

APCHMT3.m

Go to the documentation of this file.
  1. APCHMT3 ; IHS/CMI/LAB -- health summary create/modify ;
  1. ;;2.0;IHS PCC SUITE;;MAY 14, 2009
  1. ;; ;
  1. ;routine to create/modify a health summary type
  1. ;
  1. BACK ;go back to listman
  1. D TERM^VALM0
  1. S VALMBCK="R"
  1. D INIT
  1. D HDR
  1. K DIR
  1. K X,Y,Z,I
  1. Q
  1. COMP(S,C) ;EP
  1. 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
  1. Q Y
  1. TP ;EP - called from protocol entry
  1. D FULL^VALM1
  1. I '$$COMP(APCHDA,$O(^APCHSCMP("B","BEST PRACTICE PROMPTS",0))) W !!,"WARNING: Best Practice Prompts has not been added to the Health Summary",! D
  1. .W "structure. Best Practice Prompts will not display until they are part of the",!,"summary structure."
  1. .S DIR(0)="E",DIR("A")="Press enter to continue" KILL DA D ^DIR KILL DIR
  1. ;
  1. ;
  1. EN ; -- main entry point for E
  1. D EN^VALM("APCH TP EDIT")
  1. D BACK
  1. Q
  1. ;
  1. ADD ;add individual reminders or remove
  1. D FULL^VALM1
  1. W !!,"Enter the sequence number to put this Best Practice Prompt and then enter",!,"the prompt by name.",!
  1. K DIE S DA=APCHDA,DIE="^APCHSCTL(",DR=13 D ^DIE K DIE,DIV,DIW
  1. D BACK
  1. Q
  1. REM ;
  1. D FULL^VALM1
  1. S APCHSEQ=$$READ("N^0:999:","Enter the sequence number of the Best Practice Prompt to remove")
  1. I APCHSEQ="" Q
  1. I APCHSEQ="^" Q
  1. K DIRUT
  1. I '$D(^APCHSCTL(APCHDA,13,APCHSEQ,0)) W !!,"Invalid Sequence number." G REM
  1. 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
  1. D BACK
  1. Q
  1. ADDG ;add reminders by group
  1. D FULL^VALM1
  1. W !!
  1. S DIC="^APCHHMC(",DIC(0)="AEMQ",DIC("A")="Select the Category/Group of Best Practice Prompts to ADD: " D ^DIC K DIC
  1. I Y=-1 Q
  1. S APCHCAT=+Y
  1. ;add group
  1. S APCHSEQ=$$READ("N^0:999:","Enter the sequence number to place this group of Best Practice Prompts")
  1. I APCHSEQ="^" Q
  1. I APCHSEQ="" Q
  1. ;now gather up all reminder of this category and put them in
  1. ;if number already exists then move all numbers down
  1. D REMOVEG
  1. W !!,"Adding all Best Practice Prompts in the ",$P(^APCHHMC(APCHCAT,0),U)," group."
  1. 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)
  1. K ^APCHSCTL(APCHDA,13) S ^APCHSCTL(APCHDA,13,0)="^9001015.06AI^0^0"
  1. 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)
  1. ;now put in new ones
  1. 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
  1. ;now remaining old ones
  1. 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
  1. D BACK
  1. Q
  1. REMOVEG ;
  1. I $G(APCHTALK) W !!,"Removing all Best Practice Prompts in the ",$P(^APCHHMC(APCHCAT,0),U)," group."
  1. S X=0 F S X=$O(^APCHSCTL(APCHDA,13,X)) Q:X'=+X D
  1. .S Y=$P(^APCHSCTL(APCHDA,13,X,0),U,2)
  1. .I $P(^APCHSURV(Y,0),U,5)=APCHCAT K ^APCHSCTL(APCHDA,13,X,0)
  1. .Q
  1. Q
  1. REMG ;ep
  1. D FULL^VALM1
  1. W !!
  1. S DIC="^APCHHMC(",DIC(0)="AEMQ",DIC("A")="Select the Category of Best Practice Prompts to REMOVE: " D ^DIC K DIC
  1. I Y=-1 Q
  1. S APCHCAT=+Y
  1. S APCHTALK=1 D REMOVEG K APCHTALK
  1. D BACK
  1. Q
  1. ;
  1. HDR ; -- header code
  1. S VALMHDR(1)="Health Summary: "_$P(^APCHSCTL(APCHDA,0),U)
  1. Q
  1. ;
  1. INIT ; -- init variables and list array
  1. K ^TMP($J,"APCHHMRT") S APCHC=0 K APCHT
  1. S X="Note: any Best Practice Prompt flagged as inactive will not display" D S(X)
  1. S X=" on the summary even though you selected it for display. The " D S(X)
  1. S X=" Best Practice Prompt must be activated. Any Best Practice Prompts" D S(X)
  1. S X=" with (DEL) should be removed as they are no longer used." D S(X)
  1. S X="Currently defined BEST PRACTICE PROMPTS on the "_$P(^APCHSCTL(APCHDA,0),U)_" summary type" D S(X,1)
  1. S X="",$E(X,5)="SEQ",$E(X,10)="Best Practice Prompts",$E(X,65)="Category/Group" D S(X,1)
  1. S X="-------------------------------------------------------------------------------" D S(X)
  1. S Y=0,T=0 F S Y=$O(^APCHSCTL(APCHDA,13,Y)) Q:Y'=+Y D
  1. .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)
  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:"")
  1. .S $E(X,65)=$$VAL^XBDIQ1(9001018,C,.05) D S(X)
  1. .S APCHT(C)=""
  1. ;now get all those that aren't yet used
  1. S X="Other BEST PRACTICE PROMPTS not yet selected that can be " D S(X,2)
  1. S X="added to this summary type:" D S(X)
  1. S T=0 F S T=$O(^APCHSURV(T)) Q:T'=+T D
  1. .Q:$D(APCHT(T)) ;already used
  1. .Q:$P(^APCHSURV(T,0),U,3)="D"
  1. .Q:$P(^APCHSURV(T,0),U,7)'="T"
  1. .S X="",$E(X,7)=$P(^APCHSURV(T,0),U),$E(X,65)=$$VAL^XBDIQ1(9001018,T,.05) D S(X)
  1. S VALMCNT=$O(^TMP($J,"APCHHMRT",""),-1)
  1. Q
  1. S(Y,F,C,T) ;EP - set up array
  1. I '$G(F) S F=0
  1. I '$G(T) S T=0
  1. ;blank lines
  1. F F=1:1:F S X="" D S1
  1. S X=Y
  1. I $G(C) S L=$L(Y),T=(80-L)/2 D D S1 Q
  1. .F %=1:1:(T-1) S X=" "_X
  1. F %=1:1:T S X=" "_Y
  1. D S1
  1. Q
  1. S1 ;
  1. S APCHC=APCHC+1
  1. S ^TMP($J,"APCHHMRT",APCHC,0)=X
  1. Q
  1. ;
  1. HELP ; -- help code
  1. S X="?" D DISP^XQORM1 W !!
  1. Q
  1. ;
  1. EXIT ; -- EXIT code
  1. Q
  1. ;
  1. EXPND ; -- expand code
  1. Q
  1. ;
  1. PAUSE ;EP; -- ask user to press ENTER
  1. Q:IOST'["C-"
  1. NEW Y S Y=$$READ("E","Press ENTER to continue") D ^XBCLS Q
  1. READ(TYPE,PROMPT,DEFAULT,HELP,SCREEN,DIRA) ;EP; calls reader, returns response
  1. NEW DIR,X,Y
  1. S DIR(0)=TYPE
  1. I $D(SCREEN) S DIR("S")=SCREEN
  1. I $G(PROMPT)]"" S DIR("A")=PROMPT
  1. I $G(DEFAULT)]"" S DIR("B")=DEFAULT
  1. I $D(HELP) S DIR("?")=HELP
  1. I $D(DIRA(1)) S Y=0 F S Y=$O(DIRA(Y)) Q:Y="" S DIR("A",Y)=DIRA(Y)
  1. D ^DIR
  1. Q Y