Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ADEPLV1

ADEPLV1.m

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