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