APCHMT2 ; 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
MR ;EP - called from protocol entry
D FULL^VALM1
I '$$COMP(APCHDA,$O(^APCHSCMP("B","HEALTH MAINTENANCE REMINDERS",0))) W !!,"WARNING: Health Maintenance Reminders has not been added to the Health Summary",! D
.W "structure. HMR's will not display until they are part of the summary",!,"structure."
W !!,"Currently, only HEALTH REMINDERS flagged as ACTIVE will display",!,"on the health summary. If you want to activate a reminder ",!,"use the option 'AI Activate/Inactivate a Health Maintenance Reminder'",!,"to do so.",!
;S Y=$$READ("Y","Do you want to see a list of Health Maintenance Reminders before proceeding")
;I Y D VIEWR^XBLM("DSP^APCHMT1","Health Maintenance Reminder Listing")
;
EN ; -- main entry point for E
D EN^VALM("APCH HMR EDIT")
D BACK
Q
W !!
S APCHA=""
KILL DIR,DIRUT S DIR(0)="S^1:Add/Remove Health Maintenance Reminders Individually;2:Add/Remove a Group of Health Maintenance Reminders;Q:QUIT",DIR("A")="Select Action",DIR("B")="Q" KILL DA D ^DIR KILL DIR
I $D(DIRUT) D BACK Q
I Y="Q" D BACK Q
S APCHA=Y
D @APCHA
G MR
Q
ADD ;add individual reminders or remove
D FULL^VALM1
W !!,"Enter the sequence number to put this reminder and then enter",!,"reminder by name.",!
K DIE S DA=APCHDA,DIE="^APCHSCTL(",DR=6 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 reminder to remove")
I APCHSEQ="" Q
I APCHSEQ="^" Q
K DIRUT
I '$D(^APCHSCTL(APCHDA,5,APCHSEQ,0)) W !!,"Invalid Sequence number." G REM
K ^APCHSCTL(APCHDA,5,APCHSEQ) S $P(^APCHSCTL(APCHDA,5,0),U,3)=APCHSEQ,$P(^APCHSCTL(APCHDA,5,0),U,4)=$P(^APCHSCTL(APCHDA,5,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 Reminders 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 reminders")
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
K APCHC S X=0 F S X=$O(^APCHSCTL(APCHDA,5,X)) Q:X'=+X S APCHC($P(^APCHSCTL(APCHDA,5,X,0),U))=$P(^APCHSCTL(APCHDA,5,X,0),U,2)
K ^APCHSCTL(APCHDA,5) S ^APCHSCTL(APCHDA,5,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,5,X,0)=X_U_APCHC(X),C=C+1,$P(^APCHSCTL(APCHDA,5,0),U,3)=X,$P(^APCHSCTL(APCHDA,5,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)="R" S Z=Z+5,C=C+1 S ^APCHSCTL(APCHDA,5,Z,0)=Z_U_Y,$P(^APCHSCTL(APCHDA,5,0),U,3)=Z,$P(^APCHSCTL(APCHDA,5,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,5,Z,0)=Z_U_APCHC(X),$P(^APCHSCTL(APCHDA,5,0),U,3)=Z,$P(^APCHSCTL(APCHDA,5,0),U,4)=C
D BACK
Q
REMOVEG ;
W !!,"Removing all reminders in the ",$P(^APCHHMC(APCHCAT,0),U)," group."
S X=0 F S X=$O(^APCHSCTL(APCHDA,5,X)) Q:X'=+X D
.S Y=$P(^APCHSCTL(APCHDA,5,X,0),U,2)
.I $P(^APCHSURV(Y,0),U,5)=APCHCAT K ^APCHSCTL(APCHDA,5,X,0)
.Q
Q
REMG ;ep
D FULL^VALM1
W !!
S DIC="^APCHHMC(",DIC(0)="AEMQ",DIC("A")="Select the Category of Reminders to REMOVE: " D ^DIC K DIC
I Y=-1 Q
S APCHCAT=+Y
D REMOVEG
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 reminder flagged as inactive will not display on the summary" D S(X)
S X=" even though you selected it for display. The reminder must be" D S(X)
S X=" activated. Any reminders with (DEL) should be removed as they" D S(X)
S X=" are no longer used." D S(X)
S X="Currently defined HEALTH MAINTENANCE REMINDERS on the "_$P(^APCHSCTL(APCHDA,0),U)_" summary type" D S(X,1)
S X="",$E(X,5)="SEQ",$E(X,10)="Health Maintenance Reminder",$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,5,Y)) Q:Y'=+Y D
.S T=T+1 S O=$P(^APCHSCTL(APCHDA,5,Y,0),U),C=$P(^APCHSCTL(APCHDA,5,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 REMINDERS not yet selected that can be added to this summary type" D S(X,2)
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)'="R"
.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
APCHMT2 ; 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
MR ;EP - called from protocol entry
+1 DO FULL^VALM1
+2 IF '$$COMP(APCHDA,$ORDER(^APCHSCMP("B","HEALTH MAINTENANCE REMINDERS",0)))
WRITE !!,"WARNING: Health Maintenance Reminders has not been added to the Health Summary",!
Begin DoDot:1
+3 WRITE "structure. HMR's will not display until they are part of the summary",!,"structure."
End DoDot:1
+4 WRITE !!,"Currently, only HEALTH REMINDERS flagged as ACTIVE will display",!,"on the health summary. If you want to activate a reminder ",!,"use the option 'AI Activate/Inactivate a Health Maintenance Reminder'",!,"to do so.",!
+5 ;S Y=$$READ("Y","Do you want to see a list of Health Maintenance Reminders before proceeding")
+6 ;I Y D VIEWR^XBLM("DSP^APCHMT1","Health Maintenance Reminder Listing")
+7 ;
EN ; -- main entry point for E
+1 DO EN^VALM("APCH HMR EDIT")
+2 DO BACK
+3 QUIT
+4 WRITE !!
+5 SET APCHA=""
+6 KILL DIR,DIRUT
SET DIR(0)="S^1:Add/Remove Health Maintenance Reminders Individually;2:Add/Remove a Group of Health Maintenance Reminders;Q:QUIT"
SET DIR("A")="Select Action"
SET DIR("B")="Q"
KILL DA
DO ^DIR
KILL DIR
+7 IF $DATA(DIRUT)
DO BACK
QUIT
+8 IF Y="Q"
DO BACK
QUIT
+9 SET APCHA=Y
+10 DO @APCHA
+11 GOTO MR
+12 QUIT
ADD ;add individual reminders or remove
+1 DO FULL^VALM1
+2 WRITE !!,"Enter the sequence number to put this reminder and then enter",!,"reminder by name.",!
+3 KILL DIE
SET DA=APCHDA
SET DIE="^APCHSCTL("
SET DR=6
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 reminder to remove")
+3 IF APCHSEQ=""
QUIT
+4 IF APCHSEQ="^"
QUIT
+5 KILL DIRUT
+6 IF '$DATA(^APCHSCTL(APCHDA,5,APCHSEQ,0))
WRITE !!,"Invalid Sequence number."
GOTO REM
+7 KILL ^APCHSCTL(APCHDA,5,APCHSEQ)
SET $PIECE(^APCHSCTL(APCHDA,5,0),U,3)=APCHSEQ
SET $PIECE(^APCHSCTL(APCHDA,5,0),U,4)=$PIECE(^APCHSCTL(APCHDA,5,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 Reminders 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 reminders")
+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 KILL APCHC
SET X=0
FOR
SET X=$ORDER(^APCHSCTL(APCHDA,5,X))
IF X'=+X
QUIT
SET APCHC($PIECE(^APCHSCTL(APCHDA,5,X,0),U))=$PIECE(^APCHSCTL(APCHDA,5,X,0),U,2)
+14 KILL ^APCHSCTL(APCHDA,5)
SET ^APCHSCTL(APCHDA,5,0)="^9001015.06AI^0^0"
+15 SET (B,C,X)=0
FOR
SET X=$ORDER(APCHC(X))
IF X'=+X!(X>APCHSEQ)!(X=APCHSEQ)
QUIT
SET ^APCHSCTL(APCHDA,5,X,0)=X_U_APCHC(X)
SET C=C+1
SET $PIECE(^APCHSCTL(APCHDA,5,0),U,3)=X
SET $PIECE(^APCHSCTL(APCHDA,5,0),U,4)=C
SET B=X
KILL APCHC(X)
+16 ;now put in new ones
+17 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)="R"
SET Z=Z+5
SET C=C+1
SET ^APCHSCTL(APCHDA,5,Z,0)=Z_U_Y
SET $PIECE(^APCHSCTL(APCHDA,5,0),U,3)=Z
SET $PIECE(^APCHSCTL(APCHDA,5,0),U,4)=C
+18 ;now remaining old ones
+19 SET X=0
FOR
SET X=$ORDER(APCHC(X))
IF X'=+X
QUIT
SET Z=Z+5
SET C=C+1
SET ^APCHSCTL(APCHDA,5,Z,0)=Z_U_APCHC(X)
SET $PIECE(^APCHSCTL(APCHDA,5,0),U,3)=Z
SET $PIECE(^APCHSCTL(APCHDA,5,0),U,4)=C
+20 DO BACK
+21 QUIT
REMOVEG ;
+1 WRITE !!,"Removing all reminders in the ",$PIECE(^APCHHMC(APCHCAT,0),U)," group."
+2 SET X=0
FOR
SET X=$ORDER(^APCHSCTL(APCHDA,5,X))
IF X'=+X
QUIT
Begin DoDot:1
+3 SET Y=$PIECE(^APCHSCTL(APCHDA,5,X,0),U,2)
+4 IF $PIECE(^APCHSURV(Y,0),U,5)=APCHCAT
KILL ^APCHSCTL(APCHDA,5,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 Reminders to REMOVE: "
DO ^DIC
KILL DIC
+4 IF Y=-1
QUIT
+5 SET APCHCAT=+Y
+6 DO REMOVEG
+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 reminder flagged as inactive will not display on the summary"
DO S(X)
+3 SET X=" even though you selected it for display. The reminder must be"
DO S(X)
+4 SET X=" activated. Any reminders with (DEL) should be removed as they"
DO S(X)
+5 SET X=" are no longer used."
DO S(X)
+6 SET X="Currently defined HEALTH MAINTENANCE REMINDERS 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)="Health Maintenance Reminder"
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,5,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+10 SET T=T+1
SET O=$PIECE(^APCHSCTL(APCHDA,5,Y,0),U)
SET C=$PIECE(^APCHSCTL(APCHDA,5,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 REMINDERS not yet selected that can be added to this summary type"
DO S(X,2)
+16 SET T=0
FOR
SET T=$ORDER(^APCHSURV(T))
IF T'=+T
QUIT
Begin DoDot:1
+17 ;already used
IF $DATA(APCHT(T))
QUIT
+18 IF $PIECE(^APCHSURV(T,0),U,3)="D"
QUIT
+19 IF $PIECE(^APCHSURV(T,0),U,7)'="R"
QUIT
+20 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
+21 SET VALMCNT=$ORDER(^TMP($JOB,"APCHHMRT",""),-1)
+22 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
