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

APCHHMRQ.m

Go to the documentation of this file. 
  1. APCHHMRQ ; IHS/CMI/LAB - DISPLAY HEALTH MAINTENANCE REMINDER ;
  1.  ;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009
  1.  ;; ;
  1. EP ;EP - called from option to select and display a hmr
  1.  W !!,"This option will list the Health Maintenance Reminders available for display",!,"on a health summary.",!!
  1. ACT ;
  1.  S APCHACT=""
  1.  K DIR
  1.  S DIR(0)="S^A:ACTIVE Reminders (those marked as Active/'On');I:INACTIVE Reminders (those marked as Inactive/'Off');B:Both ACTIVE and INACTIVE Reminders"
  1.  S DIR("A")="List which set of Reminders",DIR("B")="B" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) D XIT Q
  1.  S APCHACT=Y
  1. SORT ;
  1.  S APCHSORT=""
  1.  S DIR(0)="S^C:By Category;N:By Name;S:Status",DIR("A")="How would you like the list sorted",DIR("B")="C" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G ACT
  1.  S APCHSORT=Y
  1. ZIS ;
  1.  S DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen",DIR("A")="Do you wish to ",DIR("B")="P" K DA D ^DIR K DIR
  1.  I $D(DIRUT) G XIT
  1.  I $G(Y)="B" D BROWSE,XIT Q
  1.  S XBRC="PROCESS^APCHHMRQ",XBRP="PRINT^APCHHMRQ",XBRX="XIT^APCHHMRQ",XBNS="APCH"
  1.  D ^XBDBQUE
  1.  D XIT
  1.  Q
  1. XIT ;
  1.  K J,K,X,Z,Y
  1.  D EN^XBVK("APCH")
  1.  Q
  1. BROWSE ;
  1.  S XBRP="VIEWR^XBLM(""PRINT^APCHHMRQ"")"
  1.  S XBNS="APCH",XBRC="PROCESS^APCHHMRQ",XBRX="XIT^APCHHMRQ",XBIOP=0 D ^XBDBQUE
  1.  Q
  1.  ;
  1. PROCESS ; -- init variables and list array
  1.  S APCHJ=$J,APCHH=$H
  1.  S ^XTMP("APCHHMRQ",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_"PCC DATA ENTRY LAB REPORT"
  1.  K ^XTMP("APCHHMRQ",APCHJ,APCHH)
  1.  S APCHN="",APCHHMR=0 F  S APCHN=$O(^APCHSURV("B",APCHN)) Q:APCHN=""  S APCHHMR=0 F  S APCHHMR=$O(^APCHSURV("B",APCHN,APCHHMR)) Q:APCHHMR'=+APCHHMR  D PROCESS1
  1.  Q
  1. PROCESS1 ;
  1.  Q:$P(^APCHSURV(APCHHMR,0),U,3)="D"
  1.  Q:$P(^APCHSURV(APCHHMR,0),U,7)'="R"
  1.  S S=$P(^APCHSURV(APCHHMR,0),U,3)
  1.  I APCHACT="A",S'=1 Q
  1.  I APCHACT="I",S'=0 Q
  1.  ;gather up reminder for display
  1.  I S="" S S=0
  1.  S C=$$VAL^XBDIQ1(9001018,APCHHMR,.05)
  1.  I C="" S C="?"
  1.  S N=$P(^APCHSURV(APCHHMR,0),U,1)
  1.  I APCHSORT="C" S ^XTMP("APCHHMRQ",APCHJ,APCHH,C,N,$$EXTSET^XBFUNC(9001018,.03,S),APCHHMR)=""
  1.  I APCHSORT="N" S ^XTMP("APCHHMRQ",APCHJ,APCHH,N,C,$$EXTSET^XBFUNC(9001018,.03,S),APCHHMR)=""
  1.  I APCHSORT="S" S ^XTMP("APCHHMRQ",APCHJ,APCHH,$$EXTSET^XBFUNC(9001018,.03,S),C,N,APCHHMR)=""
  1.  Q
  1.  ;
  1.  ;
  1. PRINT ;EP - called from xbdbque
  1.  S APCHPG=0,APCHQ=0 D HEAD
  1.  S APCHS="" F  S APCHS=$O(^XTMP("APCHHMRQ",APCHJ,APCHH,APCHS)) Q:APCHS=""!(APCHQ)  D
  1.  .S APCHC="" F  S APCHC=$O(^XTMP("APCHHMRQ",APCHJ,APCHH,APCHS,APCHC)) Q:APCHC=""!(APCHQ)  D
  1.  ..S APCHN="" F  S APCHN=$O(^XTMP("APCHHMRQ",APCHJ,APCHH,APCHS,APCHC,APCHN)) Q:APCHN=""!(APCHQ)  D
  1.  ...S APCHHMR=0 F  S APCHHMR=$O(^XTMP("APCHHMRQ",APCHJ,APCHH,APCHS,APCHC,APCHN,APCHHMR)) Q:APCHHMR=""!(APCHQ)  D
  1.  ....I $Y>(IOSL-3) D HEAD Q:APCHQ
  1.  ....W !,$E($$VAL^XBDIQ1(9001018,APCHHMR,.01),1,25),?27,$E($$VAL^XBDIQ1(9001018,APCHHMR,.05),1,15),?44,$$VAL^XBDIQ1(9001018,APCHHMR,.03)
  1.  ....S APCHSC=0,APCHZ=0
  1.  ....F  S APCHZ=$O(^APCHSCTL(APCHZ)) Q:APCHZ'=+APCHZ  D
  1.  .....S APCHK=0 F  S APCHK=$O(^APCHSCTL(APCHZ,5,APCHK)) Q:APCHK'=+APCHK!(APCHQ)  I $P(^APCHSCTL(APCHZ,5,APCHK,0),U,2)=APCHHMR W:APCHSC>0 ! W ?59,$E($P(^APCHSCTL(APCHZ,0),U),1,20) S APCHSC=APCHSC+1
  1.  .Q
  1.  ;K ^XTMP("APCHHMRQ",APCHJ,APCHH),APCHJ,APCHH
  1.  Q
  1. S(Y,F,C,T) ;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 %=$P(^XTMP("APCHHMRQ",APCHJ,APCHH,0),U)+1,$P(^XTMP("APCHHMRQ",APCHJ,APCHH,0),U)=%
  1.  S ^XTMP("APCHHMRQ",APCHJ,APCHH,%)=X
  1.  Q
  1.  I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCHQ=1 Q
  1. HEAD1 ;
  1.  W:$D(IOF) @IOF S APCHPG=APCHPG+1
  1.  W !,$P(^VA(200,DUZ,0),U,2),?72,"Page ",APCHPG,!
  1.  W ?(80-$L($P(^DIC(4,DUZ(2),0),U))/2),$P(^DIC(4,DUZ(2),0),U),!
  1.  W $$CTR("HEALTH SUMMARY HEALTH MAINTENANCE REMINDERS",80),!
  1.  W $$CTR($S(APCHACT="A":"ACTIVE",APCHACT="I":"INACTIVE",1:"BOTH ACTIVE AND INACTIVE REMINDERS"),80),!
  1.  W $TR($J("",80)," ","-"),!
  1.  W !,"REMINDER",?27,"CATEGORY",?44,"STATUS",?59,"HEALTH SUMMARY TYPES",!
  1.  W $TR($J("",80)," ","-")
  1.  Q
  1.  ;
  1. CTR(X,Y) ;EP - Center X in a field Y wide.
  1.  Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
  1.  ;----------
  1. EOP ;EP - End of page.
  1.  Q:$E(IOST)'="C"
  1.  Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
  1.  NEW DIR
  1.  K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
  1.  S DIR(0)="E" D ^DIR
  1.  Q
  1.  ;----------
  1. USR() ;EP - Return name of current user from ^VA(200.
  1.  Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
  1.  ;----------
  1. LOC() ;EP - Return location name from file 4 based on DUZ(2).
  1.  Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
  1.  ;----------