APCHHMR1 ; IHS/CMI/LAB - HMR 1 ;
;;2.0;IHS PCC SUITE;**10**;MAY 14, 2009;Build 88
;
;
EP ;EP - CALLED FROM OPTION
D EN
Q
EOJ ;EP
D EN^XBVK("APCH")
Q
;; ;
EN ; -- main entry point for APCH HMR DISPLAY
D EN^VALM("APCH HMR DISPLAY")
D CLEAR^VALM1
D FULL^VALM1
W:$D(IOF) @IOF
D EOJ
Q
;
HDR ; -- header code
S VALMHDR(1)="Health Summary Health Maintenance Item Logic Display"
Q
;
INIT ; -- init variables and list array
K APCHDISP,APCHSEL,APCHHIGH,APCHLIST,APCHCSEL
S APCHHIGH=0,X=0,N="" F S N=$O(^APCHSURV("B",N)) Q:N="" S X=0 F S X=$O(^APCHSURV("B",N,X)) Q:X'=+X I $P(^APCHSURV(X,0),U,3)'="D",$P(^APCHSURV(X,0),U,7)="R" S APCHHIGH=APCHHIGH+1,APCHSEL(APCHHIGH)=X
S APCHCUT=((APCHHIGH/3)+1)\1
;S APCHCUT=(APCHHIGH/3)\1
S (C,I)=0,J=1,K=1 F S I=$O(APCHSEL(I)) Q:I'=+I!($D(APCHDISP(I))) D
.S C=C+1,APCHLIST(C,0)=I_") "_$S($D(APCHCSEL(I)):"*",1:" ")_$E($P(^APCHSURV(APCHSEL(I),0),U),1,20) S APCHDISP(I)="",APCHLIST("IDX",C,C)=""
.S J=I+APCHCUT I $D(APCHSEL(J)),'$D(APCHDISP(J)) S $E(APCHLIST(C,0),28)=J_") "_$S($D(APCHCSEL(J)):"*",1:" ")_$E($P(^APCHSURV(APCHSEL(J),0),U),1,20) S APCHDISP(J)=""
.S K=J+APCHCUT I $D(APCHSEL(K)),'$D(APCHDISP(K)) S $E(APCHLIST(C,0),55)=K_") "_$S($D(APCHCSEL(K)):"*",1:" ")_$E($P(^APCHSURV(APCHSEL(K),0),U),1,20) S APCHDISP(K)=""
K APCHDISP
S VALMCNT=C
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
Q
;
EXPND ; -- expand code
Q
;
BACK ;go back to listman
D TERM^VALM0
S VALMBCK="R"
D INIT
D HDR
K DIR
K X,Y,Z,I
Q
;
ADD ;EP - add an item to the selected list - called from a protocol
W ! S DIR(0)="LO^1:"_APCHHIGH,DIR("A")="Which item(s)" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I Y="" W !,"No items selected." G ADDX
I $D(DIRUT) W !,"No items selected." G ADDX
D FULL^VALM1 W:$D(IOF) @IOF
S APCHANS=Y,APCHC="" F APCHI=1:1 S APCHC=$P(APCHANS,",",APCHI) Q:APCHC="" S APCHCSEL(APCHC)=""
D DISPLAY
ADDX ;
D BACK
Q
ADDALL ;
F X=1:1:APCHHIGH S APCHCSEL(X)=""
D DISPLAY
D BACK
Q
;
DISPLAY ;gather in ^TMP and display
K ^TMP("APCHHMR1",$J)
S ^TMP("APCHHMR1",$J,0)=0
S APCHC=0
S APCHX=0 F S APCHX=$O(APCHCSEL(APCHX)) Q:APCHX'=+APCHX S APCHHMR=APCHSEL(APCHX),Y="Reminder:",$E(Y,20)=$P(^APCHSURV(APCHHMR,0),U) S APCHC=APCHC+1 D S(Y,$S(APCHC=1:0,1:2)) D
.S X="",X="Status:",$E(X,20)=$$VAL^XBDIQ1(9001018,APCHHMR,.03) 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)
.I '$O(^APCHSURV(APCHHMR,11,0)) S X="<<< No Local Criteria defined >>>" D S(X)
.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)
.S X=$TR($J("",80)," ","*") D S(X,2)
;
;
K ^TMP("APCHHMR1",$J,0)
D ARRAY^XBLM("^TMP(""APCHHMR1"",$J,","HEALTH MAINTENANCE REMINDERS DESCRIPTIONS")
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(^TMP("APCHHMR1",$J,0),U)+1,$P(^TMP("APCHHMR1",$J,0),U)=%
S ^TMP("APCHHMR1",$J,%,0)=X
Q
APCHHMR1 ; IHS/CMI/LAB - HMR 1 ;
+1 ;;2.0;IHS PCC SUITE;**10**;MAY 14, 2009;Build 88
+2 ;
+3 ;
EP ;EP - CALLED FROM OPTION
+1 DO EN
+2 QUIT
EOJ ;EP
+1 DO EN^XBVK("APCH")
+2 QUIT
+3 ;; ;
EN ; -- main entry point for APCH HMR DISPLAY
+1 DO EN^VALM("APCH HMR DISPLAY")
+2 DO CLEAR^VALM1
+3 DO FULL^VALM1
+4 IF $DATA(IOF)
WRITE @IOF
+5 DO EOJ
+6 QUIT
+7 ;
HDR ; -- header code
+1 SET VALMHDR(1)="Health Summary Health Maintenance Item Logic Display"
+2 QUIT
+3 ;
INIT ; -- init variables and list array
+1 KILL APCHDISP,APCHSEL,APCHHIGH,APCHLIST,APCHCSEL
+2 SET APCHHIGH=0
SET X=0
SET N=""
FOR
SET N=$ORDER(^APCHSURV("B",N))
IF N=""
QUIT
SET X=0
FOR
SET X=$ORDER(^APCHSURV("B",N,X))
IF X'=+X
QUIT
IF $PIECE(^APCHSURV(X,0),U,3)'="D"
IF $PIECE(^APCHSURV(X,0),U,7)="R"
SET APCHHIGH=APCHHIGH+1
SET APCHSEL(APCHHIGH)=X
+3 SET APCHCUT=((APCHHIGH/3)+1)\1
+4 ;S APCHCUT=(APCHHIGH/3)\1
+5 SET (C,I)=0
SET J=1
SET K=1
FOR
SET I=$ORDER(APCHSEL(I))
IF I'=+I!($DATA(APCHDISP(I)))
QUIT
Begin DoDot:1
+6 SET C=C+1
SET APCHLIST(C,0)=I_") "_$SELECT($DATA(APCHCSEL(I)):"*",1:" ")_$EXTRACT($PIECE(^APCHSURV(APCHSEL(I),0),U),1,20)
SET APCHDISP(I)=""
SET APCHLIST("IDX",C,C)=""
+7 SET J=I+APCHCUT
IF $DATA(APCHSEL(J))
IF '$DATA(APCHDISP(J))
SET $EXTRACT(APCHLIST(C,0),28)=J_") "_$SELECT($DATA(APCHCSEL(J)):"*",1:" ")_$EXTRACT($PIECE(^APCHSURV(APCHSEL(J),0),U),1,20)
SET APCHDISP(J)=""
+8 SET K=J+APCHCUT
IF $DATA(APCHSEL(K))
IF '$DATA(APCHDISP(K))
SET $EXTRACT(APCHLIST(C,0),55)=K_") "_$SELECT($DATA(APCHCSEL(K)):"*",1:" ")_$EXTRACT($PIECE(^APCHSURV(APCHSEL(K),0),U),1,20)
SET APCHDISP(K)=""
End DoDot:1
+9 KILL APCHDISP
+10 SET VALMCNT=C
+11 QUIT
+12 ;
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 ;
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
+8 ;
ADD ;EP - add an item to the selected list - called from a protocol
+1 WRITE !
SET DIR(0)="LO^1:"_APCHHIGH
SET DIR("A")="Which item(s)"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF Y=""
WRITE !,"No items selected."
GOTO ADDX
+3 IF $DATA(DIRUT)
WRITE !,"No items selected."
GOTO ADDX
+4 DO FULL^VALM1
IF $DATA(IOF)
WRITE @IOF
+5 SET APCHANS=Y
SET APCHC=""
FOR APCHI=1:1
SET APCHC=$PIECE(APCHANS,",",APCHI)
IF APCHC=""
QUIT
SET APCHCSEL(APCHC)=""
+6 DO DISPLAY
ADDX ;
+1 DO BACK
+2 QUIT
ADDALL ;
+1 FOR X=1:1:APCHHIGH
SET APCHCSEL(X)=""
+2 DO DISPLAY
+3 DO BACK
+4 QUIT
+5 ;
DISPLAY ;gather in ^TMP and display
+1 KILL ^TMP("APCHHMR1",$JOB)
+2 SET ^TMP("APCHHMR1",$JOB,0)=0
+3 SET APCHC=0
+4 SET APCHX=0
FOR
SET APCHX=$ORDER(APCHCSEL(APCHX))
IF APCHX'=+APCHX
QUIT
SET APCHHMR=APCHSEL(APCHX)
SET Y="Reminder:"
SET $EXTRACT(Y,20)=$PIECE(^APCHSURV(APCHHMR,0),U)
SET APCHC=APCHC+1
DO S(Y,$SELECT(APCHC=1:0,1:2))
Begin DoDot:1
+5 SET X=""
SET X="Status:"
SET $EXTRACT(X,20)=$$VAL^XBDIQ1(9001018,APCHHMR,.03)
DO S(X)
+6 SET X="Description:"
DO S(X,1)
+7 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)
+8 SET X="Currently Defined Criteria in Use at this Facility:"
DO S(X,1)
+9 IF '$ORDER(^APCHSURV(APCHHMR,11,0))
SET X="<<< No Local Criteria defined >>>"
DO S(X)
+10 SET Y=0
FOR
SET Y=$ORDER(^APCHSURV(APCHHMR,11,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+11 SET Z=""
SET $EXTRACT(Z,2)="Sex: "_$SELECT($PIECE(^APCHSURV(APCHHMR,11,Y,0),U)="F":"FEMALE",$PIECE(^APCHSURV(APCHHMR,11,Y,0),U)="M":"MALE",$PIECE(^APCHSURV(APCHHMR,11,Y,0),U)="B":"ALL GENDERS",$PIECE(^APCHSURV(APCHHMR,11,Y,0),U)="U":"UN
KNOWN",1:"")
+12 SET J=0
FOR
SET J=$ORDER(^APCHSURV(APCHHMR,11,Y,11,J))
IF J'=+J
QUIT
Begin DoDot:3
+13 SET X=Z
SET $EXTRACT(X,21)="Mininum Age: "_$PIECE(^APCHSURV(APCHHMR,11,Y,11,J,0),U)
SET $EXTRACT(X,40)="Maximum Age: "_$PIECE(^APCHSURV(APCHHMR,11,Y,11,J,0),U,2)
SET $EXTRACT(X,60)="Frequency: "_$PIECE(^APCHSURV(APCHHMR,11,Y,11,J,0),U,3)
DO S(X)
End DoDot:3
+14 QUIT
End DoDot:2
+15 SET X="Currently defined on the following summary types:"
DO S(X,1)
+16 SET J=0
FOR
SET J=$ORDER(^APCHSCTL(J))
IF J'=+J
QUIT
Begin DoDot:2
+17 SET K=0
FOR
SET K=$ORDER(^APCHSCTL(J,5,K))
IF K'=+K
QUIT
IF $PIECE(^APCHSCTL(J,5,K,0),U,2)=APCHHMR
SET X=""
SET $EXTRACT(X,15)=$PIECE(^APCHSCTL(J,0),U)
DO S(X)
End DoDot:2
+18 SET X=$TRANSLATE($JUSTIFY("",80)," ","*")
DO S(X,2)
End DoDot:1
+19 ;
+20 ;
+21 KILL ^TMP("APCHHMR1",$JOB,0)
+22 DO ARRAY^XBLM("^TMP(""APCHHMR1"",$J,","HEALTH MAINTENANCE REMINDERS DESCRIPTIONS")
+23 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(^TMP("APCHHMR1",$JOB,0),U)+1
SET $PIECE(^TMP("APCHHMR1",$JOB,0),U)=%
+2 SET ^TMP("APCHHMR1",$JOB,%,0)=X
+3 QUIT
