FHMASE1A ; HISC/AAC - Multidiv Encounter Stats (cont.) ;10/14/03 13:13
;;5.5;DIETETICS;;Jan 28, 2005
Q1 ; Calculate the Encounters
K ^TMP($J)
S YX1=SDT\1-.0001,YX2=EDT\1+.3
S TIT=";"_$P(^DD(115.6,10,0),"^",3)
S D1XX="FHMASE1A"
S XX1=YX1
S (XXX,XX2,XX3,X3,XY,YY1)="",(COUNT,LL,L,D1F,D1CNTX,NUMBER)=0
S ZZCOUNT=0 F ZZCOUNT=0:0 S ZZCOUNT=$O(^FH(119.73,ZZCOUNT)) Q:ZZCOUNT'>0 S ZOUT=ZZCOUNT
F K=1:1:11 S II(K)=0,JJ(K)=0
;
Q2 ;Get Communications Offices
D DEL S (SS1,DD1,DD2,DD3,DD4,E1,COXX1,D1X,DIF,D1CNTX)=0,(NX,WW1)=""
I ZCO'="Y" S CONUMX=CONUMX-1 G:CONUMX<1 ALLTOT S COXX=$P(CO,"^",CONUMX),NAME=$P(CONAME,"^",CONUMX)
I ZCO="Y" S COUNT=COUNT+1 G:COUNT>ZOUT ALLTOT S REC=$G(^FH(119.73,COUNT,0)),NAME=$P(REC,"^",1)
;
R2 ;Find Patient records within parameters
I ZCO'="Y" G:$D(^FH(119.73,COXX,"I")) Q2 G:'$D(^FH(119.73,COXX,0)) Q2
I ZCO="Y" G:$D(^FH(119.73,COUNT,"I")) Q2 G:'$D(^FH(119.73,COUNT,0)) Q2
;
S YX1=SDT\1-.0001,YX2=EDT\1+.3,XX1=YX1
;
R1 F S XX1=$O(^FHEN("AT",XX1)) G:XX1'>0 P1 G:XX1>YX2 P1 D
R11 .S XXX=XX1 F E1=0:0 S E1=$O(^FHEN("AT",XXX,E1)) Q:E1'>0 D
..I XX1>YX2 Q
..S XX2=$G(^FHEN(E1,0))
..I ZCO'="Y" S XY=$P(XX2,"^",6) Q:COXX'=XY
..I ZCO="Y" S XY=$P(XX2,"^",6) Q:COUNT'=XY
..S Y=$G(^FHEN(E1,0))
..S D1=$P(Y,"^",3) S D2=$P(Y,"^",4),D4=$P(Y,"^",6) Q:'D2 Q:'D4
..I FHX1>0,D1'=FHX1 Q
..I $D(^FH(119.73,D4,"I")) Q
..S D6=$P(Y,"^",7),D3=$P(Y,"^",8),D9=$P(Y,"^",9),D5=$P(Y,"^",11) D C0
..S D2=$P($G(^FH(115.6,D2,0)),"^",1,2) Q:"^"[D2
..S Z1=$P(D2,"^",2),D2=$P(D2,"^",1)
..S D8=$F(TIT,";"_Z1_":") Q:D8<0
..S:D6="F" D2=D2_"~F"
..S S1=$G(^TMP($J,0,D8,D2,D4)) D UPD S ^TMP($J,0,D8,D2,D4)=S1
..S S1=$G(^TMP($J,D1,D8,D2,D4)) D UPD S ^TMP($J,D1,D8,D2,D4)=S1 S DD1=D1,DD8=D8,DD2=D2,DD4=D4 Q:'FHX2
..S (DTP,W1)=$P(Y,"^",2)\1 D DTP^FH I '$D(^TMP($J,D1,D8,D2,D4,W1)) S ^TMP($J,D1,D8,D2,D4,W1)=DTP,^(W1,0)=0 S D2=DD2,D3=DD3,D4=DD4 I '$D(^FHEN(E1,"P")) S DFN="^"_D5 D R3 Q
..F DFN=0:0 S DFN=$O(^FHEN(E1,"P",DFN)) Q:DFN<1 D R3
..Q
.Q
Q
G R11
;
R3 ;
S L=^TMP($J,D1,D8,D2,D4,W1,0)+1,^(0)=L S WW1=W1
S ^TMP($J,D1,D8,D2,D4,W1,L)=DFN Q
;
R4 ;
S DFN="^"_D5 D R3 G R2
;
C0 ;
S C(8)=$P(Y,"^",10),(C(1),C(2),C(3),C(4),C(5),C(6),C(7))=0
F DFN=0:0 S DFN=$O(^FHEN(E1,"P",DFN)) Q:DFN<1 S X=^(DFN,0) D C1
S C(7)=C(8)-C(1)-C(2)-C(4)-C(5) S:C(7)<1 C(7)=0
I D9'="I" S TM=C(1)+C(4)+C(7) I TM S TM=D3/TM,C(3)=TM*C(1),C(6)=TM*C(4),C(3)=$J(C(3),0,1),C(6)=$J(C(6),0,1) Q
Q
;
C1 ;
S Z=$P(X,"^",2) G:Z<1 C2 S Z=$P($G(^SC(+Z,0)),"^",3) G:Z'="W" C2
S C(1)=C(1)+1,C(2)=C(2)+$P(X,"^",3) S:D9="I" C(3)=C(3)+D3 Q
;
C2 ;
S C(4)=C(4)+1,C(5)=C(5)+$P(X,"^",3) S:D9="I" C(6)=C(6)+D3 Q
;
UPD ;Update S1 record
S $P(S1,"^",1)=$P(S1,"^",1)+1,$P(S1,"^",2)=$P(S1,"^",2)+D3
F K=1:1:8 I C(K) S $P(S1,"^",K+2)=$P(S1,"^",K+2)+C(K)
Q
;
P1 ;load data by paramters/totals for each Communication Office
S DTP=SDT\1 D DTP^FH S DTE=DTP_" to " S DTP=EDT\1 D DTP^FH S DTE=DTE_DTP,PG=0 D HEAD I FHX1>0 S NAM="" D D0
S (NX,D8)="",CT=0 F K=1:1:11 S (I(K),J(K))=0
;
F KK=0:0 S D8=$O(^TMP($J,0,D8)) Q:D8="" S CT=CT+1 D:CT'=1 STOT W ! D PR F K=0:0 S NX=$O(^TMP($J,0,D8,NX)) Q:NX="" S X1=$P(NX,"~",1)_$S($P(NX,"~",2)="F":" (F)",1:"") Q:X1="" S S1=$G(^TMP($J,0,D8,NX,D4)) D PP
D STOT W ! S X=" T O T A L" D PX D TOT W ! F K=1:1:11 S (I(K),J(K))=0 I FHX1<0 G Q2 D HEAD I FHX2<0 D Q2
;
P2 ;load data for each clinician
D:$Y>55 HEAD S (D8,NAM)="",CT=0
S D8=0
F D1=0:0 S D1=$O(^TMP($J,D1)) G:D1="" P2A S CT=CT+1 D:CT'=1 STOT W ! F D8=0:0 S D8=$O(^TMP($J,D1,D8)) Q:D8'>0 D PR,D0 S D2="" F L1=0:0 S D2=$O(^TMP($J,D1,D8,D2)) Q:D2="" S S1=$G(^TMP($J,D1,D8,D2,D4)) Q:S1="" D SETX1,PP I FHX2 D P3
D STOT G P2
P2A D STOT W ! S X=" TOTAL ENCOUNTERS" D TOT W @IOF D DEL S X1=SDT G Q2
;
SETX1 ;
S X1=$P(D2,"~",1)_$S($P(D2,"~",2)="F":" (F)",1:"")
Q
D0 ;Get Clinician Name
I FHX1>0 S D1=FHX1
S NAM=$P(^VA(200,D1,0),"^",1),NAM=$E(NAM,1,30) W !,NAM Q
;
P3 ;
S DTP=""
;
P4 ;
S DTP=$O(^TMP($J,D1,D8,D2,D4,DTP)) Q:DTP="" S S1=^(DTP),W1=0
;
P5 ;
S W1=$O(^TMP($J,D1,D8,D2,D4,DTP,W1)) G:W1="" P4 S DFN=^(W1) G:DFN<1 P6
S Y=$G(^DPT(DFN,0)) G:Y="" P5 D PID^FHDPA
W !?7,S1,?17,BID,?26,$P(Y,"^",1) G P5
;
P6 ;
W !?7,S1,?17,$P(DFN,"^",2) G P5
;
PP ;Print totals for Communications Offices
D:$Y>58 HEAD W !?5,X1,?47,$J($P(S1,"^",1),6,0) S I(1)=I(1)+$P(S1,"^",1),J(1)=J(1)+$P(S1,"^",1) ;)
F K=1:1:6 S Z=$P(S1,"^",K+2),I(K+2)=I(K+2)+Z,J(K+2)=J(K+2)+Z W $S(K=3!(K=6):$S(Z:$J(Z,8,1),1:$J("",8)),1:$J($S(Z:Z,1:""),6))
S Z=$P(S1,"^",9),I(9)=I(9)+$S(Z'<1:Z,1:0),J(9)=J(9)+$S(Z'<1:Z,1:0) W ?97,$J($S(Z'<1:Z,1:""),6)
;
I Z S Z=$P(S1,"^",2)-$P(S1,"^",5)-$P(S1,"^",8),I(10)=I(10)+$S(Z'<1:Z,1:0),J(10)=J(10)+$S(Z'<1:Z,1:0)
;
W $S(Z'<1:$J(Z,8,1),1:$J("",8))
S Z=$P(S1,"^",10),I(11)=I(11)+Z,J(11)=J(11)+Z W ?113,$J($S(Z'<1:Z,1:""),6)
I $P(S1,"^",2) W $J($P(S1,"^",2),8,1) S I(2)=I(2)+$P(S1,"^",2),J(2)=J(2)+$P(S1,"^",2)
;
Q
;
PX ;Accumulate amount for final total
S II(1)=II(1)+I(1) ;,II(3)=II(3)+I(3),II(6)=II(6)+I(6)
F K=1:1:6 S II(K+2)=II(K+2)+I(K+2) ;,II(K+2)=II(K+2)+I(K+2)
S II(9)=II(9)+I(9),II(10)=II(10)+I(10),II(11)=II(11)+I(11)
Q
;
PR ;
S X=$P($E(TIT,D8,999),";",1)
D:$Y>55 HEAD W !?3,X Q
Q
;
STOT ;Print sub-totals for Communications Office and Clinician
W !?5,"Subtotal",?47,$J(J(1),6) F K=1:1:6 W $S(K=3!(K=6):$S(J(K+2):$J(J(K+2),8,1),1:$J("",8)),1:$J($S(J(K+2):J(K+2),1:""),6))
W ?97,$S(J(9):$J(J(9),6),1:$J("",6)),$S(J(10):$J(J(10),8,1),1:$J("",8))
W ?113,$S(J(11):$J(J(11),6),1:$J("",6)),$S(J(2):$J(J(2),8,1),1:$J("",8)) W !
F K=1:1:11 S J(K)=0
Q
;
TOT ;
;Totals by Communications Offices
W !?3,NAME,X,?47,$J(I(1),6) F K=1:1:6 W $S(K=3!(K=6):$S(I(K+2):$J(I(K+2),8,1),1:$J("",8)),1:$J($S(I(K+2):I(K+2),1:""),6))
W ?97,$S(I(9):$J(I(9),6),1:$J("",6)),$S(I(10):$J(I(10),8,1),1:$J("",8))
W ?113,$S(I(11):$J(I(11),6),1:$J("",6)),$S(I(2):$J(I(2),8,1),1:$J("",8))
F K=1:1:11 S I(K)=0
Q
;
ALLTOT ;
;Final Totals - all Communication Offices
S XS="ALL COMMUNICATIONS OFFICES " W !,XS,?47,$J(II(1),6) F K=1:1:6 W $S(K=3!(K=6):$S(II(K+2):$J(II(K+2),8,1),1:$J("",8)),1:$J($S(II(K+2):II(K+2),1:""),6))
W ?97,$S(II(9):$J(I(9),6),1:$J("",6)),$S(II(10):$J(II(10),8,1),1:$J("",8))
W ?113,$S(II(11):$J(II(11),6),1:$J("",6)) W $S(II(5):$J(II(5),8,1),1:$J("",6))
D DEL Q
;
HEAD ;Print page headers
W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1 W !?30,"D I E T E T I C E N C O U N T E R ",?69,HEADER,?120,"Page ",PG
W !?2,NAME,?(114-$L(DTE)\2),DTE,!?47,"Number Inpatients Outpatients Others Total"
W !?56,"Pat Col Units Pat Col Units",?98,"Persn Units Persn Units",! Q
;
DEL ;DELETE RECORDS FROM ^TMP
K ^TMP($J)
W !!
Q
Q ;
QUIT ;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHMASE1A 6786 printed Nov 22, 2024@16:58:04 Page 2
FHMASE1A ; HISC/AAC - Multidiv Encounter Stats (cont.) ;10/14/03 13:13
+1 ;;5.5;DIETETICS;;Jan 28, 2005
Q1 ; Calculate the Encounters
+1 KILL ^TMP($JOB)
+2 SET YX1=SDT\1-.0001
SET YX2=EDT\1+.3
+3 SET TIT=";"_$PIECE(^DD(115.6,10,0),"^",3)
+4 SET D1XX="FHMASE1A"
+5 SET XX1=YX1
+6 SET (XXX,XX2,XX3,X3,XY,YY1)=""
SET (COUNT,LL,L,D1F,D1CNTX,NUMBER)=0
+7 SET ZZCOUNT=0
FOR ZZCOUNT=0:0
SET ZZCOUNT=$ORDER(^FH(119.73,ZZCOUNT))
if ZZCOUNT'>0
QUIT
SET ZOUT=ZZCOUNT
+8 FOR K=1:1:11
SET II(K)=0
SET JJ(K)=0
+9 ;
Q2 ;Get Communications Offices
+1 DO DEL
SET (SS1,DD1,DD2,DD3,DD4,E1,COXX1,D1X,DIF,D1CNTX)=0
SET (NX,WW1)=""
+2 IF ZCO'="Y"
SET CONUMX=CONUMX-1
if CONUMX<1
GOTO ALLTOT
SET COXX=$PIECE(CO,"^",CONUMX)
SET NAME=$PIECE(CONAME,"^",CONUMX)
+3 IF ZCO="Y"
SET COUNT=COUNT+1
if COUNT>ZOUT
GOTO ALLTOT
SET REC=$GET(^FH(119.73,COUNT,0))
SET NAME=$PIECE(REC,"^",1)
+4 ;
R2 ;Find Patient records within parameters
+1 IF ZCO'="Y"
if $DATA(^FH(119.73,COXX,"I"))
GOTO Q2
if '$DATA(^FH(119.73,COXX,0))
GOTO Q2
+2 IF ZCO="Y"
if $DATA(^FH(119.73,COUNT,"I"))
GOTO Q2
if '$DATA(^FH(119.73,COUNT,0))
GOTO Q2
+3 ;
+4 SET YX1=SDT\1-.0001
SET YX2=EDT\1+.3
SET XX1=YX1
+5 ;
R1 FOR
SET XX1=$ORDER(^FHEN("AT",XX1))
if XX1'>0
GOTO P1
if XX1>YX2
GOTO P1
Begin DoDot:1
R11 SET XXX=XX1
FOR E1=0:0
SET E1=$ORDER(^FHEN("AT",XXX,E1))
if E1'>0
QUIT
Begin DoDot:2
+1 IF XX1>YX2
QUIT
+2 SET XX2=$GET(^FHEN(E1,0))
+3 IF ZCO'="Y"
SET XY=$PIECE(XX2,"^",6)
if COXX'=XY
QUIT
+4 IF ZCO="Y"
SET XY=$PIECE(XX2,"^",6)
if COUNT'=XY
QUIT
+5 SET Y=$GET(^FHEN(E1,0))
+6 SET D1=$PIECE(Y,"^",3)
SET D2=$PIECE(Y,"^",4)
SET D4=$PIECE(Y,"^",6)
if 'D2
QUIT
if 'D4
QUIT
+7 IF FHX1>0
IF D1'=FHX1
QUIT
+8 IF $DATA(^FH(119.73,D4,"I"))
QUIT
+9 SET D6=$PIECE(Y,"^",7)
SET D3=$PIECE(Y,"^",8)
SET D9=$PIECE(Y,"^",9)
SET D5=$PIECE(Y,"^",11)
DO C0
+10 SET D2=$PIECE($GET(^FH(115.6,D2,0)),"^",1,2)
if "^"[D2
QUIT
+11 SET Z1=$PIECE(D2,"^",2)
SET D2=$PIECE(D2,"^",1)
+12 SET D8=$FIND(TIT,";"_Z1_":")
if D8<0
QUIT
+13 if D6="F"
SET D2=D2_"~F"
+14 SET S1=$GET(^TMP($JOB,0,D8,D2,D4))
DO UPD
SET ^TMP($JOB,0,D8,D2,D4)=S1
+15 SET S1=$GET(^TMP($JOB,D1,D8,D2,D4))
DO UPD
SET ^TMP($JOB,D1,D8,D2,D4)=S1
SET DD1=D1
SET DD8=D8
SET DD2=D2
SET DD4=D4
if 'FHX2
QUIT
+16 SET (DTP,W1)=$PIECE(Y,"^",2)\1
DO DTP^FH
IF '$DATA(^TMP($JOB,D1,D8,D2,D4,W1))
SET ^TMP($JOB,D1,D8,D2,D4,W1)=DTP
SET ^(W1,0)=0
SET D2=DD2
SET D3=DD3
SET D4=DD4
IF '$DATA(^FHEN(E1,"P"))
SET DFN="^"_D5
DO R3
QUIT
+17 FOR DFN=0:0
SET DFN=$ORDER(^FHEN(E1,"P",DFN))
if DFN<1
QUIT
DO R3
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 QUIT
+21 GOTO R11
+22 ;
R3 ;
+1 SET L=^TMP($JOB,D1,D8,D2,D4,W1,0)+1
SET ^(0)=L
SET WW1=W1
+2 SET ^TMP($JOB,D1,D8,D2,D4,W1,L)=DFN
QUIT
+3 ;
R4 ;
+1 SET DFN="^"_D5
DO R3
GOTO R2
+2 ;
C0 ;
+1 SET C(8)=$PIECE(Y,"^",10)
SET (C(1),C(2),C(3),C(4),C(5),C(6),C(7))=0
+2 FOR DFN=0:0
SET DFN=$ORDER(^FHEN(E1,"P",DFN))
if DFN<1
QUIT
SET X=^(DFN,0)
DO C1
+3 SET C(7)=C(8)-C(1)-C(2)-C(4)-C(5)
if C(7)<1
SET C(7)=0
+4 IF D9'="I"
SET TM=C(1)+C(4)+C(7)
IF TM
SET TM=D3/TM
SET C(3)=TM*C(1)
SET C(6)=TM*C(4)
SET C(3)=$JUSTIFY(C(3),0,1)
SET C(6)=$JUSTIFY(C(6),0,1)
QUIT
+5 QUIT
+6 ;
C1 ;
+1 SET Z=$PIECE(X,"^",2)
if Z<1
GOTO C2
SET Z=$PIECE($GET(^SC(+Z,0)),"^",3)
if Z'="W"
GOTO C2
+2 SET C(1)=C(1)+1
SET C(2)=C(2)+$PIECE(X,"^",3)
if D9="I"
SET C(3)=C(3)+D3
QUIT
+3 ;
C2 ;
+1 SET C(4)=C(4)+1
SET C(5)=C(5)+$PIECE(X,"^",3)
if D9="I"
SET C(6)=C(6)+D3
QUIT
+2 ;
UPD ;Update S1 record
+1 SET $PIECE(S1,"^",1)=$PIECE(S1,"^",1)+1
SET $PIECE(S1,"^",2)=$PIECE(S1,"^",2)+D3
+2 FOR K=1:1:8
IF C(K)
SET $PIECE(S1,"^",K+2)=$PIECE(S1,"^",K+2)+C(K)
+3 QUIT
+4 ;
P1 ;load data by paramters/totals for each Communication Office
+1 SET DTP=SDT\1
DO DTP^FH
SET DTE=DTP_" to "
SET DTP=EDT\1
DO DTP^FH
SET DTE=DTE_DTP
SET PG=0
DO HEAD
IF FHX1>0
SET NAM=""
DO D0
+2 SET (NX,D8)=""
SET CT=0
FOR K=1:1:11
SET (I(K),J(K))=0
+3 ;
+4 FOR KK=0:0
SET D8=$ORDER(^TMP($JOB,0,D8))
if D8=""
QUIT
SET CT=CT+1
if CT'=1
DO STOT
WRITE !
DO PR
FOR K=0:0
SET NX=$ORDER(^TMP($JOB,0,D8,NX))
if NX=""
QUIT
SET X1=$PIECE(NX,"~",1)_$SELECT($PIECE(NX,"~",2)="F":" (F)",1:"")
if X1=""
QUIT
SET S1=$GET(^TMP($JOB,0,D8,NX,D4))
DO PP
+5 DO STOT
WRITE !
SET X=" T O T A L"
DO PX
DO TOT
WRITE !
FOR K=1:1:11
SET (I(K),J(K))=0
IF FHX1<0
GOTO Q2
DO HEAD
IF FHX2<0
DO Q2
+6 ;
P2 ;load data for each clinician
+1 if $Y>55
DO HEAD
SET (D8,NAM)=""
SET CT=0
+2 SET D8=0
+3 FOR D1=0:0
SET D1=$ORDER(^TMP($JOB,D1))
if D1=""
GOTO P2A
SET CT=CT+1
if CT'=1
DO STOT
WRITE !
FOR D8=0:0
SET D8=$ORDER(^TMP($JOB,D1,D8))
if D8'>0
QUIT
DO PR
DO D0
SET D2=""
FOR L1=0:0
SET D2=$ORDER(^TMP($JOB,D1,D8,D2))
if D2=""
QUIT
SET S1=$GET(^TMP($JOB,D1,D8,D2,D4))
if S1=""
QUIT
DO SETX1
DO PP
IF FHX2
DO P3
+4 DO STOT
GOTO P2
P2A DO STOT
WRITE !
SET X=" TOTAL ENCOUNTERS"
DO TOT
WRITE @IOF
DO DEL
SET X1=SDT
GOTO Q2
+1 ;
SETX1 ;
+1 SET X1=$PIECE(D2,"~",1)_$SELECT($PIECE(D2,"~",2)="F":" (F)",1:"")
+2 QUIT
D0 ;Get Clinician Name
+1 IF FHX1>0
SET D1=FHX1
+2 SET NAM=$PIECE(^VA(200,D1,0),"^",1)
SET NAM=$EXTRACT(NAM,1,30)
WRITE !,NAM
QUIT
+3 ;
P3 ;
+1 SET DTP=""
+2 ;
P4 ;
+1 SET DTP=$ORDER(^TMP($JOB,D1,D8,D2,D4,DTP))
if DTP=""
QUIT
SET S1=^(DTP)
SET W1=0
+2 ;
P5 ;
+1 SET W1=$ORDER(^TMP($JOB,D1,D8,D2,D4,DTP,W1))
if W1=""
GOTO P4
SET DFN=^(W1)
if DFN<1
GOTO P6
+2 SET Y=$GET(^DPT(DFN,0))
if Y=""
GOTO P5
DO PID^FHDPA
+3 WRITE !?7,S1,?17,BID,?26,$PIECE(Y,"^",1)
GOTO P5
+4 ;
P6 ;
+1 WRITE !?7,S1,?17,$PIECE(DFN,"^",2)
GOTO P5
+2 ;
PP ;Print totals for Communications Offices
+1 ;)
if $Y>58
DO HEAD
WRITE !?5,X1,?47,$JUSTIFY($PIECE(S1,"^",1),6,0)
SET I(1)=I(1)+$PIECE(S1,"^",1)
SET J(1)=J(1)+$PIECE(S1,"^",1)
+2 FOR K=1:1:6
SET Z=$PIECE(S1,"^",K+2)
SET I(K+2)=I(K+2)+Z
SET J(K+2)=J(K+2)+Z
WRITE $SELECT(K=3!(K=6):$SELECT(Z:$JUSTIFY(Z,8,1),1:$JUSTIFY("",8)),1:$JUSTIFY($SELECT(Z:Z,1:""),6))
+3 SET Z=$PIECE(S1,"^",9)
SET I(9)=I(9)+$SELECT(Z'<1:Z,1:0)
SET J(9)=J(9)+$SELECT(Z'<1:Z,1:0)
WRITE ?97,$JUSTIFY($SELECT(Z'<1:Z,1:""),6)
+4 ;
+5 IF Z
SET Z=$PIECE(S1,"^",2)-$PIECE(S1,"^",5)-$PIECE(S1,"^",8)
SET I(10)=I(10)+$SELECT(Z'<1:Z,1:0)
SET J(10)=J(10)+$SELECT(Z'<1:Z,1:0)
+6 ;
+7 WRITE $SELECT(Z'<1:$JUSTIFY(Z,8,1),1:$JUSTIFY("",8))
+8 SET Z=$PIECE(S1,"^",10)
SET I(11)=I(11)+Z
SET J(11)=J(11)+Z
WRITE ?113,$JUSTIFY($SELECT(Z'<1:Z,1:""),6)
+9 IF $PIECE(S1,"^",2)
WRITE $JUSTIFY($PIECE(S1,"^",2),8,1)
SET I(2)=I(2)+$PIECE(S1,"^",2)
SET J(2)=J(2)+$PIECE(S1,"^",2)
+10 ;
+11 QUIT
+12 ;
PX ;Accumulate amount for final total
+1 ;,II(3)=II(3)+I(3),II(6)=II(6)+I(6)
SET II(1)=II(1)+I(1)
+2 ;,II(K+2)=II(K+2)+I(K+2)
FOR K=1:1:6
SET II(K+2)=II(K+2)+I(K+2)
+3 SET II(9)=II(9)+I(9)
SET II(10)=II(10)+I(10)
SET II(11)=II(11)+I(11)
+4 QUIT
+5 ;
PR ;
+1 SET X=$PIECE($EXTRACT(TIT,D8,999),";",1)
+2 if $Y>55
DO HEAD
WRITE !?3,X
QUIT
+3 QUIT
+4 ;
STOT ;Print sub-totals for Communications Office and Clinician
+1 WRITE !?5,"Subtotal",?47,$JUSTIFY(J(1),6)
FOR K=1:1:6
WRITE $SELECT(K=3!(K=6):$SELECT(J(K+2):$JUSTIFY(J(K+2),8,1),1:$JUSTIFY("",8)),1:$JUSTIFY($SELECT(J(K+2):J(K+2),1:""),6))
+2 WRITE ?97,$SELECT(J(9):$JUSTIFY(J(9),6),1:$JUSTIFY("",6)),$SELECT(J(10):$JUSTIFY(J(10),8,1),1:$JUSTIFY("",8))
+3 WRITE ?113,$SELECT(J(11):$JUSTIFY(J(11),6),1:$JUSTIFY("",6)),$SELECT(J(2):$JUSTIFY(J(2),8,1),1:$JUSTIFY("",8))
WRITE !
+4 FOR K=1:1:11
SET J(K)=0
+5 QUIT
+6 ;
TOT ;
+1 ;Totals by Communications Offices
+2 WRITE !?3,NAME,X,?47,$JUSTIFY(I(1),6)
FOR K=1:1:6
WRITE $SELECT(K=3!(K=6):$SELECT(I(K+2):$JUSTIFY(I(K+2),8,1),1:$JUSTIFY("",8)),1:$JUSTIFY($SELECT(I(K+2):I(K+2),1:""),6))
+3 WRITE ?97,$SELECT(I(9):$JUSTIFY(I(9),6),1:$JUSTIFY("",6)),$SELECT(I(10):$JUSTIFY(I(10),8,1),1:$JUSTIFY("",8))
+4 WRITE ?113,$SELECT(I(11):$JUSTIFY(I(11),6),1:$JUSTIFY("",6)),$SELECT(I(2):$JUSTIFY(I(2),8,1),1:$JUSTIFY("",8))
+5 FOR K=1:1:11
SET I(K)=0
+6 QUIT
+7 ;
ALLTOT ;
+1 ;Final Totals - all Communication Offices
+2 SET XS="ALL COMMUNICATIONS OFFICES "
WRITE !,XS,?47,$JUSTIFY(II(1),6)
FOR K=1:1:6
WRITE $SELECT(K=3!(K=6):$SELECT(II(K+2):$JUSTIFY(II(K+2),8,1),1:$JUSTIFY("",8)),1:$JUSTIFY($SELECT(II(K+2):II(K+2),1:""),6))
+3 WRITE ?97,$SELECT(II(9):$JUSTIFY(I(9),6),1:$JUSTIFY("",6)),$SELECT(II(10):$JUSTIFY(II(10),8,1),1:$JUSTIFY("",8))
+4 WRITE ?113,$SELECT(II(11):$JUSTIFY(II(11),6),1:$JUSTIFY("",6))
WRITE $SELECT(II(5):$JUSTIFY(II(5),8,1),1:$JUSTIFY("",6))
+5 DO DEL
QUIT
+6 ;
HEAD ;Print page headers
+1 if '($EXTRACT(IOST,1,2)'="C-"&'PG)
WRITE @IOF
SET PG=PG+1
WRITE !?30,"D I E T E T I C E N C O U N T E R ",?69,HEADER,?120,"Page ",PG
+2 WRITE !?2,NAME,?(114-$LENGTH(DTE)\2),DTE,!?47,"Number Inpatients Outpatients Others Total"
+3 WRITE !?56,"Pat Col Units Pat Col Units",?98,"Persn Units Persn Units",!
QUIT
+4 ;
DEL ;DELETE RECORDS FROM ^TMP
+1 KILL ^TMP($JOB)
+2 WRITE !!
+3 QUIT
Q ;
QUIT ;
+1 QUIT
