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

APCHMT2.m

Go to the documentation of this file. 
  1. APCHMT2 ; 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. MR ;EP - called from protocol entry
  1.  D FULL^VALM1
  1.  I '$$COMP(APCHDA,$O(^APCHSCMP("B","HEALTH MAINTENANCE REMINDERS",0))) W !!,"WARNING:  Health Maintenance Reminders has not been added to the Health Summary",! D
  1.  .W "structure.  HMR's will not display until they are part of the summary",!,"structure."
  1.  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.",!
  1.  ;S Y=$$READ("Y","Do you want to see a list of Health Maintenance Reminders before proceeding")
  1.  ;I Y D VIEWR^XBLM("DSP^APCHMT1","Health Maintenance Reminder Listing")
  1.  ;
  1. EN ; -- main entry point for E
  1.  D EN^VALM("APCH HMR EDIT")
  1.  D BACK
  1.  Q
  1.  W !!
  1.  S APCHA=""
  1.  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
  1.  I $D(DIRUT) D BACK Q
  1.  I Y="Q" D BACK Q
  1.  S APCHA=Y
  1.  D @APCHA
  1.  G MR
  1.  Q
  1. ADD ;add individual reminders or remove
  1.  D FULL^VALM1
  1.  W !!,"Enter the sequence number to put this reminder and then enter",!,"reminder by name.",!
  1.  K DIE S DA=APCHDA,DIE="^APCHSCTL(",DR=6 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 reminder to remove")
  1.  I APCHSEQ="" Q
  1.  I APCHSEQ="^" Q
  1.  K DIRUT
  1.  I '$D(^APCHSCTL(APCHDA,5,APCHSEQ,0)) W !!,"Invalid Sequence number." G REM
  1.  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
  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 Reminders 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 reminders")
  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.  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)
  1.  K ^APCHSCTL(APCHDA,5) S ^APCHSCTL(APCHDA,5,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,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)
  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)="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
  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,5,Z,0)=Z_U_APCHC(X),$P(^APCHSCTL(APCHDA,5,0),U,3)=Z,$P(^APCHSCTL(APCHDA,5,0),U,4)=C
  1.  D BACK
  1.  Q
  1. REMOVEG ;
  1.  W !!,"Removing all reminders in the ",$P(^APCHHMC(APCHCAT,0),U)," group."
  1.  S X=0 F  S X=$O(^APCHSCTL(APCHDA,5,X)) Q:X'=+X  D
  1.  .S Y=$P(^APCHSCTL(APCHDA,5,X,0),U,2)
  1.  .I $P(^APCHSURV(Y,0),U,5)=APCHCAT K ^APCHSCTL(APCHDA,5,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 Reminders to REMOVE: " D ^DIC K DIC
  1.  I Y=-1 Q
  1.  S APCHCAT=+Y
  1.  D REMOVEG
  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 reminder flagged as inactive will not display on the summary" D S(X)
  1.  S X="      even though you selected it for display.  The reminder must be" D S(X)
  1.  S X="      activated.  Any reminders with (DEL) should be removed as they" D S(X)
  1.  S X="      are no longer used." D S(X)
  1.  S X="Currently defined HEALTH MAINTENANCE REMINDERS on the "_$P(^APCHSCTL(APCHDA,0),U)_" summary type" D S(X,1)
  1.  S X="",$E(X,5)="SEQ",$E(X,10)="Health Maintenance Reminder",$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,5,Y)) Q:Y'=+Y  D
  1.  .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)
  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 REMINDERS not yet selected that can be added to this summary type" D S(X,2)
  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)'="R"
  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