APCHHMRP ; IHS/CMI/LAB - DISPLAY HEALTH MAINTENANCE REMINDER ;
;;2.0;IHS PCC SUITE;**2,10**;MAY 14, 2009;Build 88
;; ;
EP ;EP - called from option to select and display a hmr
W !!,"This option will display or print the description/logic of all Health",!,"Summary Maintenance Reminders.",!!
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^APCHHMRP",XBRP="PRINT^APCHHMRP",XBRX="XIT^APCHHMRP",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^APCHHMRP"")"
S XBNS="APCH",XBRC="PROCESS^APCHHMRP",XBRX="XIT^APCHHMRP",XBIOP=0 D ^XBDBQUE
Q
;
PROCESS ; -- init variables and list array
S APCHJ=$J,APCHH=$H
S ^XTMP("APCHHMRP",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_"PCC DATA ENTRY LAB REPORT"
K ^XTMP("APCHHMRP",APCHJ,APCHH)
S ^XTMP("APCHHMRP",APCHJ,APCHH,0)=0
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
K ^XTMP("APCHHMRP",APCHJ,APCHH,0)
Q
PROCESS1 ;
Q:$P(^APCHSURV(APCHHMR,0),U,3)="D"
Q:$P(^APCHSURV(APCHHMR,0),U,7)'="R"
;gather up reminder for display
S X="",X="Reminder:",$E(X,20)=$P(^APCHSURV(APCHHMR,0),U) D S(X,1)
;S X="",X="Status:",$E(X,20)=$$VAL^XBDIQ1(9001018,APCHHMR,.03) D S(X)
S X="",X="Category:",$E(X,20)=$$VAL^XBDIQ1(9001018,APCHHMR,.05) D S(X)
S X="Description:" D S(X,1)
S Y=0 F S Y=$O(^APCHSURV(APCHHMR,1,Y)) Q:Y'=+Y S X="",$E(X,2)=^APCHSURV(APCHHMR,1,Y,0) D S(X)
;S X="Currently Defined Criteria in Use at this Facility:" D S(X,1)
;S Y=0 F S Y=$O(^APCHSURV(APCHHMR,11,Y)) Q:Y'=+Y D
;.S Z="",$E(Z,2)="Sex: "_$S($P(^APCHSURV(APCHHMR,11,Y,0),U)="F":"FEMALE",$P(^APCHSURV(APCHHMR,11,Y,0),U)="M":"MALE",$P(^APCHSURV(APCHHMR,11,Y,0),U)="B":"ALL GENDERS",$P(^APCHSURV(APCHHMR,11,Y,0),U)="U":"UNKNOWN",1:"")
;.S J=0 F S J=$O(^APCHSURV(APCHHMR,11,Y,11,J)) Q:J'=+J D
;..S X=Z,$E(X,21)="Mininum Age: "_$P(^APCHSURV(APCHHMR,11,Y,11,J,0),U),$E(X,40)="Maximum Age: "_$P(^APCHSURV(APCHHMR,11,Y,11,J,0),U,2),$E(X,60)="Frequency: "_$P(^APCHSURV(APCHHMR,11,Y,11,J,0),U,3) D S(X)
;..Q
;S X="Currently defined on the following summary types:" D S(X,1)
;S J=0 F S J=$O(^APCHSCTL(J)) Q:J'=+J D
;.S K=0 F S K=$O(^APCHSCTL(J,5,K)) Q:K'=+K I $P(^APCHSCTL(J,5,K,0),U,2)=APCHHMR S X="",$E(X,15)=$P(^APCHSCTL(J,0),U) D S(X)
;.Q
S X=$TR($J("",80)," ","*") D S(X,2)
Q
;
;
PRINT ;EP - called from xbdbque
S APCHPG=0,APCHQ=0 D HEAD
S APCHX=0 F S APCHX=$O(^XTMP("APCHHMRP",APCHJ,APCHH,APCHX)) Q:APCHX'=+APCHX!(APCHQ) D
.I $Y>(IOSL-3) D HEAD Q:APCHQ
.W !,^XTMP("APCHHMRP",APCHJ,APCHH,APCHX)
.Q
K ^XTMP("APCHHMRP",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("APCHHMRP",APCHJ,APCHH,0),U)+1,$P(^XTMP("APCHHMRP",APCHJ,APCHH,0),U)=%
S ^XTMP("APCHHMRP",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 !,$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")
;----------
APCHHMRP ; IHS/CMI/LAB - DISPLAY HEALTH MAINTENANCE REMINDER ;
+1 ;;2.0;IHS PCC SUITE;**2,10**;MAY 14, 2009;Build 88
+2 ;; ;
EP ;EP - called from option to select and display a hmr
+1 WRITE !!,"This option will display or print the description/logic of all Health",!,"Summary Maintenance Reminders.",!!
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^APCHHMRP"
SET XBRP="PRINT^APCHHMRP"
SET XBRX="XIT^APCHHMRP"
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^APCHHMRP"")"
+2 SET XBNS="APCH"
SET XBRC="PROCESS^APCHHMRP"
SET XBRX="XIT^APCHHMRP"
SET XBIOP=0
DO ^XBDBQUE
+3 QUIT
+4 ;
PROCESS ; -- init variables and list array
+1 SET APCHJ=$JOB
SET APCHH=$HOROLOG
+2 SET ^XTMP("APCHHMRP",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_"PCC DATA ENTRY LAB REPORT"
+3 KILL ^XTMP("APCHHMRP",APCHJ,APCHH)
+4 SET ^XTMP("APCHHMRP",APCHJ,APCHH,0)=0
+5 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
+6 KILL ^XTMP("APCHHMRP",APCHJ,APCHH,0)
+7 QUIT
PROCESS1 ;
+1 IF $PIECE(^APCHSURV(APCHHMR,0),U,3)="D"
QUIT
+2 IF $PIECE(^APCHSURV(APCHHMR,0),U,7)'="R"
QUIT
+3 ;gather up reminder for display
+4 SET X=""
SET X="Reminder:"
SET $EXTRACT(X,20)=$PIECE(^APCHSURV(APCHHMR,0),U)
DO S(X,1)
+5 ;S X="",X="Status:",$E(X,20)=$$VAL^XBDIQ1(9001018,APCHHMR,.03) D S(X)
+6 SET X=""
SET X="Category:"
SET $EXTRACT(X,20)=$$VAL^XBDIQ1(9001018,APCHHMR,.05)
DO S(X)
+7 SET X="Description:"
DO S(X,1)
+8 SET Y=0
FOR
SET Y=$ORDER(^APCHSURV(APCHHMR,1,Y))
IF Y'=+Y
QUIT
SET X=""
SET $EXTRACT(X,2)=^APCHSURV(APCHHMR,1,Y,0)
DO S(X)
+9 ;S X="Currently Defined Criteria in Use at this Facility:" D S(X,1)
+10 ;S Y=0 F S Y=$O(^APCHSURV(APCHHMR,11,Y)) Q:Y'=+Y D
+11 ;.S Z="",$E(Z,2)="Sex: "_$S($P(^APCHSURV(APCHHMR,11,Y,0),U)="F":"FEMALE",$P(^APCHSURV(APCHHMR,11,Y,0),U)="M":"MALE",$P(^APCHSURV(APCHHMR,11,Y,0),U)="B":"ALL GENDERS",$P(^APCHSURV(APCHHMR,11,Y,0),U)="U":"UNKNOWN",1:"")
+12 ;.S J=0 F S J=$O(^APCHSURV(APCHHMR,11,Y,11,J)) Q:J'=+J D
+13 ;..S X=Z,$E(X,21)="Mininum Age: "_$P(^APCHSURV(APCHHMR,11,Y,11,J,0),U),$E(X,40)="Maximum Age: "_$P(^APCHSURV(APCHHMR,11,Y,11,J,0),U,2),$E(X,60)="Frequency: "_$P(^APCHSURV(APCHHMR,11,Y,11,J,0),U,3) D S(X)
+14 ;..Q
+15 ;S X="Currently defined on the following summary types:" D S(X,1)
+16 ;S J=0 F S J=$O(^APCHSCTL(J)) Q:J'=+J D
+17 ;.S K=0 F S K=$O(^APCHSCTL(J,5,K)) Q:K'=+K I $P(^APCHSCTL(J,5,K,0),U,2)=APCHHMR S X="",$E(X,15)=$P(^APCHSCTL(J,0),U) D S(X)
+18 ;.Q
+19 SET X=$TRANSLATE($JUSTIFY("",80)," ","*")
DO S(X,2)
+20 QUIT
+21 ;
+22 ;
PRINT ;EP - called from xbdbque
+1 SET APCHPG=0
SET APCHQ=0
DO HEAD
+2 SET APCHX=0
FOR
SET APCHX=$ORDER(^XTMP("APCHHMRP",APCHJ,APCHH,APCHX))
IF APCHX'=+APCHX!(APCHQ)
QUIT
Begin DoDot:1
+3 IF $Y>(IOSL-3)
DO HEAD
IF APCHQ
QUIT
+4 WRITE !,^XTMP("APCHHMRP",APCHJ,APCHH,APCHX)
+5 QUIT
End DoDot:1
+6 KILL ^XTMP("APCHHMRP",APCHJ,APCHH),APCHJ,APCHH
+7 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("APCHHMRP",APCHJ,APCHH,0),U)+1
SET $PIECE(^XTMP("APCHHMRP",APCHJ,APCHH,0),U)=%
+2 SET ^XTMP("APCHHMRP",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 !,$TRANSLATE($JUSTIFY("",80)," ","-")
+6 QUIT
+7 ;
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 ;----------
