ADEPLV1 ; IHS/HQT/MJL - DENTAL LVL OF SVC ; [ 03/24/1999 9:04 AM ]
;;6.0;ADE;**15**;JAN 01, 2004
START ;EP - TASKMAN PROCESSING PHASE
I $D(ZTQUEUED) L +@ADEGBL:1 I '$T S ZTREQ="@" G END
D ^XBKVAR S ADEDT=ADEBDT-1,ADEDT=ADEDT_".9999"
;B "S+"
W:'$D(ZTQUEUED) !,"Please wait while I scan the records"
S @ADEGBL@(0)="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0"
;BEGIN IHS MODIFICATIONS ADE*6.0*15
S @ADEGBL@(0,"RVU")="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0"
;END IHS MODIFICATIONS
ROLL S ADEDFN=0,ADEDT=$O(^ADEPCD("AC",ADEDT)) G:(ADEDT="")!(ADEDT>ADEND) ROLLEND W:'$D(ZTQUEUED) "."
RO1 S ADEDFN=$O(^ADEPCD("AC",ADEDT,ADEDFN)) G:ADEDFN="" ROLL
G:'$D(^ADEPCD(ADEDFN,0)) RO1
S ADENOD=^ADEPCD(ADEDFN,0)
I ADECON,$P(ADENOD,U,9)'="c" G RO1
;*P2*IHS/HMW Inserted G:$P..."d" in next line
I ADEDIR G:$P(ADENOD,U,9)'="d" RO1 S ADEY=0 D IND G:'ADEY RO1
;*P2*IHS/HMW Replaced call to NON with call to IND
I ADENON S ADEY=0 D IND G:ADEY RO1
S ADELOE=$P(ADENOD,U,3) G:ADELOE=""!('$D(^AUTTLOC(ADELOE))) RO1
S:'$D(@ADEGBL@(ADELOE,0)) @ADEGBL@(ADELOE,0)="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0"
;BEGIN IHS MODIFICATIONS ADE*6.0*15
S:'$D(@ADEGBL@(ADELOE,0)) @ADEGBL@(ADELOE,0,"RVU")="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0"
;END IHS MODIFICATIONS
I ADEPDET S ADERPD=$P(ADENOD,U,ADEPRO) G:ADERPD="" RO1 G:$P(^DIC(6,ADERPD,0),U,4)']"" RO1 I ADEPRO=5,^DIC(7,$P(^DIC(6,ADERPD,0),U,4),9999999)=52 G RO1
I ADEPDET S:'$D(@ADEGBL@(ADELOE,ADERPD)) @ADEGBL@(ADELOE,ADERPD)="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0"
;BEGIN IHS MODIFICATIONS ADE*6.1*15
I ADEPDET S:'$D(@ADEGBL@(ADELOE,ADERPD)) @ADEGBL@(ADELOE,ADERPD,"RVU")="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0"
;END IHS MODIFICATIONS
S ADESVC=0 F J=0:0 S ADESVC=$O(^ADEPCD(ADEDFN,"ADA",ADESVC)) Q:'+ADESVC D RO3
G RO1
RO3 Q:'$D(^ADEPCD(ADEDFN,"ADA",ADESVC,0)) S ADEACP=$P(^ADEPCD(ADEDFN,"ADA",ADESVC,0),U)
;Screen out Unreportable codes:
Q:$P(^ADEPCD(ADEDFN,"ADA",ADESVC,0),U,5)]""
Q:'$D(^AUTTADA(ADEACP,0))
;----- BEGIN IHS MODIFICATIONS ADE*6.0*15
S ADERVU=$P($G(^AUTTADA(ADEACP,5)),U)
;----- END IHS MODIFICATIONS
S ADESM=$P(^AUTTADA(ADEACP,0),U,4),ADELVL=$P(^(0),U,5) Q:ADELVL=""
S:ADELVL=9 ADELVL=7 S ADEPC=(ADELVL*2)+1
I ADEPDET S $P(@ADEGBL@(ADELOE,ADERPD),U,ADEPC)=$P(@ADEGBL@(ADELOE,ADERPD),U,ADEPC)+1,$P(@ADEGBL@(ADELOE,ADERPD),U,ADEPC+1)=$P(@ADEGBL@(ADELOE,ADERPD),U,ADEPC+1)+ADESM
;----- BEGIN IHS MODIFICATIONS ADE*6.0*15
I ADEPDET S $P(@ADEGBL@(ADELOE,ADERPD,"RVU"),U,ADEPC)=$P($G(@ADEGBL@(ADELOE,ADERPD,"RVU")),U,ADEPC)+1,$P(@ADEGBL@(ADELOE,ADERPD,"RVU"),U,ADEPC+1)=$P($G(@ADEGBL@(ADELOE,ADERPD,"RVU")),U,ADEPC+1)+ADERVU
;---- END IHS MODIFICATIONS
S $P(@ADEGBL@(0),U,ADEPC)=$P(@ADEGBL@(0),U,ADEPC)+1,$P(@ADEGBL@(0),U,ADEPC+1)=$P(@ADEGBL@(0),U,ADEPC+1)+ADESM
;----- BEGIN IHS MODIFICATIONS ADE*6.0*15
S $P(@ADEGBL@(0,"RVU"),U,ADEPC)=$P($G(@ADEGBL@(0,"RVU")),U,ADEPC)+1
S $P(@ADEGBL@(0,"RVU"),U,ADEPC+1)=$P($G(@ADEGBL@(0,"RVU")),U,ADEPC+1)+ADERVU
;----- END IHS MODIFICATIONS
S $P(@ADEGBL@(ADELOE,0),U,ADEPC)=$P(@ADEGBL@(ADELOE,0),U,ADEPC)+1,$P(@ADEGBL@(ADELOE,0),U,ADEPC+1)=$P(@ADEGBL@(ADELOE,0),U,ADEPC+1)+ADESM
;
;----- BEGIN IHS MODIFICATION ADE*6.0*15
S $P(@ADEGBL@(ADELOE,0,"RVU"),U,ADEPC)=$P($G(@ADEGBL@(ADELOE,0,"RVU")),U,ADEPC)+1
S $P(@ADEGBL@(ADELOE,0,"RVU"),U,ADEPC+1)=$P($G(@ADEGBL@(ADELOE,0,"RVU")),U,ADEPC+1)+ADERVU
;----- END IHS MODIFICATIONS
Q
;
ROLLEND S @ADEGBL=ADEBDT_U_ADEND_U_DT_U_"LEVEL OF SERVICE REPORT"_ADETITL
;
I $D(ZTQUEUED),$D(IOT),IOT'="HFS" D G END2
. L -@ADEGBL
. S ZTREQ=$H_U_ADEIOP_U_"DENTAL LVL REPT PRINTING"_U_"PRINT^ADEPLV1"
I $D(ZTQUEUED) L -@ADEGBL ;MUST BE HFS
;
PRINT ;EP - TASKMAN PRINT PHASE
I $D(ZTQUEUED) L +@ADEGBL:1 I '$T S ADENOLOK=1 G END
S IOP=ADEIOP
S %ZIS("IOPAR")=ADEIOPAR
D ^%ZIS
U IO
S (ADEQIT,ADELOE)=0,ADEPAG=1,$P(ADELIN,"-",79)="",ADEBDT=$P(@ADEGBL,U),ADEND=$P(@ADEGBL,U,2)
S Y=ADEBDT X ^DD("DD") S ADEBDT=Y,Y=ADEND X ^DD("DD") S ADEND=Y
P1 S ADERPD=0,ADELOE=$O(@ADEGBL@(ADELOE)) G:ADELOE="" FACTOT
S ADEFAC=$P(^AUTTLOC(ADELOE,0),U,2) D EOP1 G:ADEQIT END
P2 ;I ADEPDET S ADERPD=$O(@ADEGBL@(ADELOE,ADERPD)) I '+ADERPD S ADEDAT=@ADEGBL@(ADELOE,0) W !,"TOTAL FOR ",ADEFAC,":" D CALC G:ADEQIT END G P1
;----- BEGIN IHS MODIFICATION ADE*6.0*15
I ADEPDET S ADERPD=$O(@ADEGBL@(ADELOE,ADERPD)) I '+ADERPD S ADEDAT=@ADEGBL@(ADELOE,0),ADERVUD=@ADEGBL@(ADELOE,0,"RVU") W !,"TOTAL FOR ",ADEFAC,":" D CALC G:ADEQIT END G P1
;----- END IHS MODIFICATIONS
;I ADEPDET W !,$P(^DIC(16,ADERPD,0),U) S ADEDAT=@ADEGBL@(ADELOE,ADERPD) D CALC G:ADEQIT END G P2
;-----BEGIN IHS MODIFICATIONS ADE*6.0*15
I ADEPDET W !,$P(^DIC(16,ADERPD,0),U) S ADEDAT=@ADEGBL@(ADELOE,ADERPD),ADERVUD=@ADEGBL@(ADELOE,ADERPD,"RVU") D CALC G:ADEQIT END G P2
;----- END IHS MODIFICATIONS
;S ADEDAT=@ADEGBL@(ADELOE,0) W !,"TOTAL FOR ",ADEFAC,":" D CALC G:ADEQIT END G P1
;BEGIN IHS MODIFICATIONS ADE*6.0*15
S ADEDAT=@ADEGBL@(ADELOE,0),ADERVUD=@ADEGBL@(ADELOE,0,"RVU") W !,"TOTAL FOR ",ADEFAC,":" D CALC G:ADEQIT END G P1
;----- END IHS MODIFICATIONS
CALC ;
;S (ADESMRT,ADESVRT)=0
;----- BEGIN IHS MODIFICATIONS ADE*6.0*15
S (ADESMRT,ADESVRT,ADERVUTO)=0
;----- END IHS MODIFICATIONS
;F Z=1:1:8 S ADELV=Z-1 S:ADELV=7 ADELV=9 W !,"LEVEL ",ADELV,": ",?20,$J($P(ADEDAT,U,(Z*2-1)),4),?30,$J($P(ADEDAT,U,Z*2),6) S:ADELV>0&(ADELV<7) ADESVRT=ADESVRT+$P(ADEDAT,U,(Z*2-1)),ADESMRT=ADESMRT+$P(ADEDAT,U,(Z*2)) D EOP Q:ADEQIT
F Z=1:1:8 D Q:ADEQIT
. S ADELV=Z-1
. S:ADELV=7 ADELV=9
. W !,"LEVEL ",ADELV,":"
. W ?20,$J($P(ADEDAT,U,(Z*2-1)),4)
. W ?30,$J($P(ADEDAT,U,Z*2),6)
. W ?40,$J(+$P($G(ADERVUD),U,Z*2),6)
. I (ADELV>0&(ADELV<7)) D
. . S ADESVRT=ADESVRT+$P(ADEDAT,U,(Z*2-1))
. . S ADESMRT=ADESMRT+$P(ADEDAT,U,(Z*2))
. . S ADERVUTO=ADERVUTO+$P($G(ADERVUD),U,Z*2)
. D EOP
;F Z=1:1:8 S ADELV=Z-1 S:ADELV=7 ADELV=9 W !,"LEVEL ",ADELV,": ",?20,$J($P(ADEDAT,U,(Z*2-1)),4),?30,$J($P(ADEDAT,U,Z*2),6),?40,$J(+$P($G(ADERVUD),U,Z*2),6) S:ADELV>0&(ADELV<7) ADESVRT=ADESVRT+$P(ADEDAT,U,(Z*2-1)),ADESMRT=ADESMRT+$P(ADEDAT,U,(Z*2)),ADERVUTO=ADERVUTO+$P($G(ADERVUD),U,Z*2) D EOP Q:ADEQIT
;
;W !,"TOTAL LVL 1-6: ",?20,$J(ADESVRT,4),?30,$J(ADESMRT,6)
;----- BEGIN IHS MODIFICATIONS ADE*6.0*15
W !,"TOTAL LVL 1-6: ",?20,$J(ADESVRT,4),?30,$J(ADESMRT,6),?40,$J(ADERVUTO,6)
;----- END IHS MODIFICATIONS
D EOP Q
FACTOT ;D EOP1 G:ADEQIT END S ADEFAC="TOTAL FOR ALL FACILITIES",ADEDAT=@ADEGBL@(0) D HEADER,CALC G:ADEQIT END
;BEGIN IHS MODIFCATIONS ADE*6.0*15
D EOP1 G:ADEQIT END S ADEFAC="TOTAL FOR ALL FACILITIES",ADEDAT=@ADEGBL@(0),ADERVUD=@ADEGBL@(0,"RVU") D HEADER,CALC G:ADEQIT END
;END IHS MODIFICATIONS
;
END I $D(ZTQUEUED) S ZTREQ="@"
L -@ADEGBL
I '$D(ADENOLOK) K @ADEGBL
END2 ;
D ^%ZISC
;BEGIN IHS MODIFICATIONS ADE*6.0*15
K ADERVUD
;END IHS MODIFICATIONS
K ADENOLOK,ADEIOP,ADEIOPAR
K ADENOD,ADEACP,ADEFAC,ADEOLD,ADELIN,ADEPAG,ADELOE,ADERPD,ADEDAT,ADEDT,ADEBDT,ADEND,ADEQIT,ADESMRT,ADESVRT,ADELV,ADEDIR,ADECON,ADETITL,ADEGBL,ADEPRO
K ADEPDET,ADENON,ADEY,ADESVC,ADELVL,ADEPC,ADESM,ADEDFN,ADEPAT Q
;
EOP Q:$Y'>(IOSL-5)
EOP1 I ADEPAG'=1,$P(IOST,"-")["C" W *7 R !,X:DTIME I ('$T)!(X["^") S ADEQIT=1 Q
D:ADELOE'="" HEADER Q
;W !!,?20,"SVCS",?30,"MINUTES",!,ADELIN
;----- BEGIN IHS MODIFICATIONS ADE*6.0*15
W !!,?20,"SVCS",?30,"MINUTES",?40,"RVUs",!,ADELIN
;----- END IHS MODIFICATIONS
S ADEPAG=ADEPAG+1 Q
NON S ADEPAT=$P(ADENOD,U) Q:'+ADEPAT
Q:'$D(^AUPNPAT(ADEPAT,11))
Q:$P(^AUPNPAT(ADEPAT,11),U,8)'=1
S ADEY=1
Q
IND ;CALLED WITH ADEY=0
;RETURN ADEY=0 IF NON-INDIAN
; ADEY=1 IF INDIAN OR NO TRIBE ENTRY
;IHS/HMW ADEK Replaced entire subroutine with next 2 lines
S ADEY=0 Q:'+$P(ADENOD,U)
S ADEY=$$INDIAN^ADEKNT($P(ADENOD,U)) S:ADEY=2 ADEY=0 Q
ADEPLV1 ; IHS/HQT/MJL - DENTAL LVL OF SVC ; [ 03/24/1999 9:04 AM ]
+1 ;;6.0;ADE;**15**;JAN 01, 2004
START ;EP - TASKMAN PROCESSING PHASE
+1 IF $DATA(ZTQUEUED)
LOCK +@ADEGBL:1
IF '$TEST
SET ZTREQ="@"
GOTO END
+2 DO ^XBKVAR
SET ADEDT=ADEBDT-1
SET ADEDT=ADEDT_".9999"
+3 ;B "S+"
+4 IF '$DATA(ZTQUEUED)
WRITE !,"Please wait while I scan the records"
+5 SET @ADEGBL@(0)="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0"
+6 ;BEGIN IHS MODIFICATIONS ADE*6.0*15
+7 SET @ADEGBL@(0,"RVU")="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0"
+8 ;END IHS MODIFICATIONS
ROLL SET ADEDFN=0
SET ADEDT=$ORDER(^ADEPCD("AC",ADEDT))
IF (ADEDT="")!(ADEDT>ADEND)
GOTO ROLLEND
IF '$DATA(ZTQUEUED)
WRITE "."
RO1 SET ADEDFN=$ORDER(^ADEPCD("AC",ADEDT,ADEDFN))
IF ADEDFN=""
GOTO ROLL
+1 IF '$DATA(^ADEPCD(ADEDFN,0))
GOTO RO1
+2 SET ADENOD=^ADEPCD(ADEDFN,0)
+3 IF ADECON
IF $PIECE(ADENOD,U,9)'="c"
GOTO RO1
+4 ;*P2*IHS/HMW Inserted G:$P..."d" in next line
+5 IF ADEDIR
IF $PIECE(ADENOD,U,9)'="d"
GOTO RO1
SET ADEY=0
DO IND
IF 'ADEY
GOTO RO1
+6 ;*P2*IHS/HMW Replaced call to NON with call to IND
+7 IF ADENON
SET ADEY=0
DO IND
IF ADEY
GOTO RO1
+8 SET ADELOE=$PIECE(ADENOD,U,3)
IF ADELOE=""!('$DATA(^AUTTLOC(ADELOE)))
GOTO RO1
+9 IF '$DATA(@ADEGBL@(ADELOE,0))
SET @ADEGBL@(ADELOE,0)="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0"
+10 ;BEGIN IHS MODIFICATIONS ADE*6.0*15
+11 IF '$DATA(@ADEGBL@(ADELOE,0))
SET @ADEGBL@(ADELOE,0,"RVU")="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0"
+12 ;END IHS MODIFICATIONS
+13 IF ADEPDET
SET ADERPD=$PIECE(ADENOD,U,ADEPRO)
IF ADERPD=""
GOTO RO1
IF $PIECE(^DIC(6,ADERPD,0),U,4)']""
GOTO RO1
IF ADEPRO=5
IF ^DIC(7,$PIECE(^DIC(6,ADERPD,0),U,4),9999999)=52
GOTO RO1
+14 IF ADEPDET
IF '$DATA(@ADEGBL@(ADELOE,ADERPD))
SET @ADEGBL@(ADELOE,ADERPD)="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0"
+15 ;BEGIN IHS MODIFICATIONS ADE*6.1*15
+16 IF ADEPDET
IF '$DATA(@ADEGBL@(ADELOE,ADERPD))
SET @ADEGBL@(ADELOE,ADERPD,"RVU")="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0"
+17 ;END IHS MODIFICATIONS
+18 SET ADESVC=0
FOR J=0:0
SET ADESVC=$ORDER(^ADEPCD(ADEDFN,"ADA",ADESVC))
IF '+ADESVC
QUIT
DO RO3
+19 GOTO RO1
RO3 IF '$DATA(^ADEPCD(ADEDFN,"ADA",ADESVC,0))
QUIT
SET ADEACP=$PIECE(^ADEPCD(ADEDFN,"ADA",ADESVC,0),U)
+1 ;Screen out Unreportable codes:
+2 IF $PIECE(^ADEPCD(ADEDFN,"ADA",ADESVC,0),U,5)]""
QUIT
+3 IF '$DATA(^AUTTADA(ADEACP,0))
QUIT
+4 ;----- BEGIN IHS MODIFICATIONS ADE*6.0*15
+5 SET ADERVU=$PIECE($GET(^AUTTADA(ADEACP,5)),U)
+6 ;----- END IHS MODIFICATIONS
+7 SET ADESM=$PIECE(^AUTTADA(ADEACP,0),U,4)
SET ADELVL=$PIECE(^(0),U,5)
IF ADELVL=""
QUIT
+8 IF ADELVL=9
SET ADELVL=7
SET ADEPC=(ADELVL*2)+1
+9 IF ADEPDET
SET $PIECE(@ADEGBL@(ADELOE,ADERPD),U,ADEPC)=$PIECE(@ADEGBL@(ADELOE,ADERPD),U,ADEPC)+1
SET $PIECE(@ADEGBL@(ADELOE,ADERPD),U,ADEPC+1)=$PIECE(@ADEGBL@(ADELOE,ADERPD),U,ADEPC+1)+ADESM
+10 ;----- BEGIN IHS MODIFICATIONS ADE*6.0*15
+11 IF ADEPDET
SET $PIECE(@ADEGBL@(ADELOE,ADERPD,"RVU"),U,ADEPC)=$PIECE($GET(@ADEGBL@(ADELOE,ADERPD,"RVU")),U,ADEPC)+1
SET $PIECE(@ADEGBL@(ADELOE,ADERPD,"RVU"),U,ADEPC+1)=$PIECE($GET(@ADEGBL@(ADELOE,ADERPD,"RVU")),U,ADEPC+1)+ADERVU
+12 ;---- END IHS MODIFICATIONS
+13 SET $PIECE(@ADEGBL@(0),U,ADEPC)=$PIECE(@ADEGBL@(0),U,ADEPC)+1
SET $PIECE(@ADEGBL@(0),U,ADEPC+1)=$PIECE(@ADEGBL@(0),U,ADEPC+1)+ADESM
+14 ;----- BEGIN IHS MODIFICATIONS ADE*6.0*15
+15 SET $PIECE(@ADEGBL@(0,"RVU"),U,ADEPC)=$PIECE($GET(@ADEGBL@(0,"RVU")),U,ADEPC)+1
+16 SET $PIECE(@ADEGBL@(0,"RVU"),U,ADEPC+1)=$PIECE($GET(@ADEGBL@(0,"RVU")),U,ADEPC+1)+ADERVU
+17 ;----- END IHS MODIFICATIONS
+18 SET $PIECE(@ADEGBL@(ADELOE,0),U,ADEPC)=$PIECE(@ADEGBL@(ADELOE,0),U,ADEPC)+1
SET $PIECE(@ADEGBL@(ADELOE,0),U,ADEPC+1)=$PIECE(@ADEGBL@(ADELOE,0),U,ADEPC+1)+ADESM
+19 ;
+20 ;----- BEGIN IHS MODIFICATION ADE*6.0*15
+21 SET $PIECE(@ADEGBL@(ADELOE,0,"RVU"),U,ADEPC)=$PIECE($GET(@ADEGBL@(ADELOE,0,"RVU")),U,ADEPC)+1
+22 SET $PIECE(@ADEGBL@(ADELOE,0,"RVU"),U,ADEPC+1)=$PIECE($GET(@ADEGBL@(ADELOE,0,"RVU")),U,ADEPC+1)+ADERVU
+23 ;----- END IHS MODIFICATIONS
+24 QUIT
+25 ;
ROLLEND SET @ADEGBL=ADEBDT_U_ADEND_U_DT_U_"LEVEL OF SERVICE REPORT"_ADETITL
+1 ;
+2 IF $DATA(ZTQUEUED)
IF $DATA(IOT)
IF IOT'="HFS"
Begin DoDot:1
+3 LOCK -@ADEGBL
+4 SET ZTREQ=$HOROLOG_U_ADEIOP_U_"DENTAL LVL REPT PRINTING"_U_"PRINT^ADEPLV1"
End DoDot:1
GOTO END2
+5 ;MUST BE HFS
IF $DATA(ZTQUEUED)
LOCK -@ADEGBL
+6 ;
PRINT ;EP - TASKMAN PRINT PHASE
+1 IF $DATA(ZTQUEUED)
LOCK +@ADEGBL:1
IF '$TEST
SET ADENOLOK=1
GOTO END
+2 SET IOP=ADEIOP
+3 SET %ZIS("IOPAR")=ADEIOPAR
+4 DO ^%ZIS
+5 USE IO
+6 SET (ADEQIT,ADELOE)=0
SET ADEPAG=1
SET $PIECE(ADELIN,"-",79)=""
SET ADEBDT=$PIECE(@ADEGBL,U)
SET ADEND=$PIECE(@ADEGBL,U,2)
+7 SET Y=ADEBDT
XECUTE ^DD("DD")
SET ADEBDT=Y
SET Y=ADEND
XECUTE ^DD("DD")
SET ADEND=Y
P1 SET ADERPD=0
SET ADELOE=$ORDER(@ADEGBL@(ADELOE))
IF ADELOE=""
GOTO FACTOT
+1 SET ADEFAC=$PIECE(^AUTTLOC(ADELOE,0),U,2)
DO EOP1
IF ADEQIT
GOTO END
P2 ;I ADEPDET S ADERPD=$O(@ADEGBL@(ADELOE,ADERPD)) I '+ADERPD S ADEDAT=@ADEGBL@(ADELOE,0) W !,"TOTAL FOR ",ADEFAC,":" D CALC G:ADEQIT END G P1
+1 ;----- BEGIN IHS MODIFICATION ADE*6.0*15
+2 IF ADEPDET
SET ADERPD=$ORDER(@ADEGBL@(ADELOE,ADERPD))
IF '+ADERPD
SET ADEDAT=@ADEGBL@(ADELOE,0)
SET ADERVUD=@ADEGBL@(ADELOE,0,"RVU")
WRITE !,"TOTAL FOR ",ADEFAC,":"
DO CALC
IF ADEQIT
GOTO END
GOTO P1
+3 ;----- END IHS MODIFICATIONS
+4 ;I ADEPDET W !,$P(^DIC(16,ADERPD,0),U) S ADEDAT=@ADEGBL@(ADELOE,ADERPD) D CALC G:ADEQIT END G P2
+5 ;-----BEGIN IHS MODIFICATIONS ADE*6.0*15
+6 IF ADEPDET
WRITE !,$PIECE(^DIC(16,ADERPD,0),U)
SET ADEDAT=@ADEGBL@(ADELOE,ADERPD)
SET ADERVUD=@ADEGBL@(ADELOE,ADERPD,"RVU")
DO CALC
IF ADEQIT
GOTO END
GOTO P2
+7 ;----- END IHS MODIFICATIONS
+8 ;S ADEDAT=@ADEGBL@(ADELOE,0) W !,"TOTAL FOR ",ADEFAC,":" D CALC G:ADEQIT END G P1
+9 ;BEGIN IHS MODIFICATIONS ADE*6.0*15
+10 SET ADEDAT=@ADEGBL@(ADELOE,0)
SET ADERVUD=@ADEGBL@(ADELOE,0,"RVU")
WRITE !,"TOTAL FOR ",ADEFAC,":"
DO CALC
IF ADEQIT
GOTO END
GOTO P1
+11 ;----- END IHS MODIFICATIONS
CALC ;
+1 ;S (ADESMRT,ADESVRT)=0
+2 ;----- BEGIN IHS MODIFICATIONS ADE*6.0*15
+3 SET (ADESMRT,ADESVRT,ADERVUTO)=0
+4 ;----- END IHS MODIFICATIONS
+5 ;F Z=1:1:8 S ADELV=Z-1 S:ADELV=7 ADELV=9 W !,"LEVEL ",ADELV,": ",?20,$J($P(ADEDAT,U,(Z*2-1)),4),?30,$J($P(ADEDAT,U,Z*2),6) S:ADELV>0&(ADELV<7) ADESVRT=ADESVRT+$P(ADEDAT,U,(Z*2-1)),ADESMRT=ADESMRT+$P(ADEDAT,U,(Z*2)) D EOP Q:ADEQIT
+6 FOR Z=1:1:8
Begin DoDot:1
+7 SET ADELV=Z-1
+8 IF ADELV=7
SET ADELV=9
+9 WRITE !,"LEVEL ",ADELV,":"
+10 WRITE ?20,$JUSTIFY($PIECE(ADEDAT,U,(Z*2-1)),4)
+11 WRITE ?30,$JUSTIFY($PIECE(ADEDAT,U,Z*2),6)
+12 WRITE ?40,$JUSTIFY(+$PIECE($GET(ADERVUD),U,Z*2),6)
+13 IF (ADELV>0&(ADELV<7))
Begin DoDot:2
+14 SET ADESVRT=ADESVRT+$PIECE(ADEDAT,U,(Z*2-1))
+15 SET ADESMRT=ADESMRT+$PIECE(ADEDAT,U,(Z*2))
+16 SET ADERVUTO=ADERVUTO+$PIECE($GET(ADERVUD),U,Z*2)
End DoDot:2
+17 DO EOP
End DoDot:1
IF ADEQIT
QUIT
+18 ;F Z=1:1:8 S ADELV=Z-1 S:ADELV=7 ADELV=9 W !,"LEVEL ",ADELV,": ",?20,$J($P(ADEDAT,U,(Z*2-1)),4),?30,$J($P(ADEDAT,U,Z*2),6),?40,$J(+$P($G(ADERVUD),U,Z*2),6) S:ADELV>0&(ADELV<7) ADESVRT=ADESVRT+$P(ADEDAT,U,(Z*2-1)),ADESMRT=ADESMRT+$P(ADEDAT,U,(Z*2
)),ADERVUTO=ADERVUTO+$P($G(ADERVUD),U,Z*2) D EOP Q:ADEQIT
+19 ;
+20 ;W !,"TOTAL LVL 1-6: ",?20,$J(ADESVRT,4),?30,$J(ADESMRT,6)
+21 ;----- BEGIN IHS MODIFICATIONS ADE*6.0*15
+22 WRITE !,"TOTAL LVL 1-6: ",?20,$JUSTIFY(ADESVRT,4),?30,$JUSTIFY(ADESMRT,6),?40,$JUSTIFY(ADERVUTO,6)
+23 ;----- END IHS MODIFICATIONS
+24 DO EOP
QUIT
FACTOT ;D EOP1 G:ADEQIT END S ADEFAC="TOTAL FOR ALL FACILITIES",ADEDAT=@ADEGBL@(0) D HEADER,CALC G:ADEQIT END
+1 ;BEGIN IHS MODIFCATIONS ADE*6.0*15
+2 DO EOP1
IF ADEQIT
GOTO END
SET ADEFAC="TOTAL FOR ALL FACILITIES"
SET ADEDAT=@ADEGBL@(0)
SET ADERVUD=@ADEGBL@(0,"RVU")
DO HEADER
DO CALC
IF ADEQIT
GOTO END
+3 ;END IHS MODIFICATIONS
+4 ;
END IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+1 LOCK -@ADEGBL
+2 IF '$DATA(ADENOLOK)
KILL @ADEGBL
END2 ;
+1 DO ^%ZISC
+2 ;BEGIN IHS MODIFICATIONS ADE*6.0*15
+3 KILL ADERVUD
+4 ;END IHS MODIFICATIONS
+5 KILL ADENOLOK,ADEIOP,ADEIOPAR
+6 KILL ADENOD,ADEACP,ADEFAC,ADEOLD,ADELIN,ADEPAG,ADELOE,ADERPD,ADEDAT,ADEDT,ADEBDT,ADEND,ADEQIT,ADESMRT,ADESVRT,ADELV,ADEDIR,ADECON,ADETITL,ADEGBL,ADEPRO
+7 KILL ADEPDET,ADENON,ADEY,ADESVC,ADELVL,ADEPC,ADESM,ADEDFN,ADEPAT
QUIT
+8 ;
EOP IF $Y'>(IOSL-5)
QUIT
EOP1 IF ADEPAG'=1
IF $PIECE(IOST,"-")["C"
WRITE *7
READ !,X:DTIME
IF ('$TEST)!(X["^")
SET ADEQIT=1
QUIT
+1 IF ADELOE'=""
DO HEADER
QUIT
+1 ;W !!,?20,"SVCS",?30,"MINUTES",!,ADELIN
+2 ;----- BEGIN IHS MODIFICATIONS ADE*6.0*15
+3 WRITE !!,?20,"SVCS",?30,"MINUTES",?40,"RVUs",!,ADELIN
+4 ;----- END IHS MODIFICATIONS
+5 SET ADEPAG=ADEPAG+1
QUIT
NON SET ADEPAT=$PIECE(ADENOD,U)
IF '+ADEPAT
QUIT
+1 IF '$DATA(^AUPNPAT(ADEPAT,11))
QUIT
+2 IF $PIECE(^AUPNPAT(ADEPAT,11),U,8)'=1
QUIT
+3 SET ADEY=1
+4 QUIT
IND ;CALLED WITH ADEY=0
+1 ;RETURN ADEY=0 IF NON-INDIAN
+2 ; ADEY=1 IF INDIAN OR NO TRIBE ENTRY
+3 ;IHS/HMW ADEK Replaced entire subroutine with next 2 lines
+4 SET ADEY=0
IF '+$PIECE(ADENOD,U)
QUIT
+5 SET ADEY=$$INDIAN^ADEKNT($PIECE(ADENOD,U))
IF ADEY=2
SET ADEY=0
QUIT
