ADEFPC1 ; IHS/HQT/MJL - F- COMPLIANCE PART 2 ;07:54 PM [ 03/24/1999 9:04 AM ]
;;6.0;ADE;;APRIL 1999
;
S ADEOPT=$P(ADEWSNOD,"^",5) S ADEOPT=$S(ADEOPT="A":1.2,ADEOPT="B":1.1,ADEOPT="D":.9,ADEOPT="E":.8,ADEOPT="F":.7,1:1)
S ADENAT=$P(ADEWSNOD,"^",4)
S ADEPOP=$P(ADEWSNOD,"^",7)
;
S (ADETDAY,ADETPPM,ADETCNT,ADELAT,ADEABS,ADESTOP)=0
S ADEBM=$E(ADEBD,1,5),ADEEM=$E(ADEED,1,5)
;
S ADEABS=$O(^ADEFLU(ADEFLDFN,1,"AB",ADEABS)),ADEABSMO=$E(ADEABS,1,5) Q:ADEABS=""
CONTROL ;------->INCREMENT FOR EACH MONTH IN REPORT
F ADECUR=ADEBM:1 S:$E(ADECUR,4,5)=13 ADECUR=ADECUR+88 Q:ADECUR>ADEEM D LENGTH,CURMO,SYSET,SUSET,ARSET^ADEFPC3
;------->SET SYSTEM TOTAL FOR ENTIRE DATE RANGE
D SYSTOT^ADEFPC3
END Q
;
;
CURMO ;------->PROCESS CURRENT MONTH ADECUR
S (ADEQ,ADEMPPM,ADEMCNT)=0
I ADESTOP S ADEMCNT=0,ADEINC=ADECML,ADEMPPM=ADECPPM*ADEINC Q
I ADECUR<ADEABSMO S ADEMCNT=0,ADEMPPM=0 Q
I ADECUR=ADEABSMO S ADELAT=ADEABS,ADEMCNT=1
I '+ADELAT D LATEST
S ADEQ=0 F ADEK=0:0 S ADENEX=$O(^ADEFLU(ADEFLDFN,1,"AB",ADELAT)),ADENEXMO=$E(ADENEX,1,5) D PPM,MONTH Q:ADEQ
S:ADECUR=ADEABSMO ADECML=ADECML-$E(ADEABS,6,7) S:ADECML=0 ADECML=1
Q
LATEST ;------->RETURNS DATE OF LATEST ENTRY BEFORE FIRST MONTH OF PROCESSING
S ADELAT=ADEABS F ADEJ=0:0 S ADETST=$O(^ADEFLU(ADEFLDFN,1,"AB",ADELAT)) Q:ADETST="" S:$E(ADETST,1,5)<ADECUR ADELAT=ADETST Q:ADELAT'=ADETST
Q
PPM ;------->RETURNS ADECPPM FOR ENTRY DATED ADELAT
S ADEX=$O(^ADEFLU(ADEFLDFN,1,"AB",ADELAT,0)),ADECPPM=$P(^ADEFLU(ADEFLDFN,1,ADEX,0),U,2) Q
MONTH ;------->STEP THROUGH CURRENT MONTH ENTRIES AND CALCULATE
;---NEXT IN CURRENT MONTH, PREVIOUS ENTRY IN PREVIOUS MONTH
I ADENEXMO=ADECUR,$E(ADELAT,1,5)<ADECUR S ADEINC=ADENEX-(ADECUR_"00"),ADEMPPM=ADEMPPM+(ADEINC*ADECPPM),ADELAT=ADENEX,ADEMCNT=ADEMCNT+1 Q
;---NEXT AND PREVIOUS ENTRIES WITHIN THE CURRENT MONTH
I ADENEXMO=ADECUR S ADEINC=ADENEX-ADELAT,ADEMPPM=ADEMPPM+(ADEINC*ADECPPM),ADELAT=ADENEX,ADEMCNT=ADEMCNT+1 D PPM Q
;---NEXT ENTRY IS GREATER THAN CURRENT MONTH
I ADENEXMO>ADECUR S ADEINC=$S($E(ADELAT,1,5)<ADECUR:ADECML,1:(ADECUR_ADECML)-ADELAT) S:ADEINC=0 ADEINC=1 S ADEMPPM=ADEMPPM+(ADEINC*ADECPPM),ADEQ=1 Q
;---NEXT ENTRY IS NULL, PREVIOUS ENTRY IN PREVIOUS MONTH
I ADENEXMO="",$E(ADELAT,1,5)<ADECUR S ADEINC=ADECML,ADEMPPM=ADEMPPM+(ADEINC*ADECPPM),ADEQ=1,ADESTOP=1 Q
;---NEXT ENTRY NULL, PREVIOUS ENTRY IN CURRENT MONTH
I ADENEXMO="" S ADEINC=ADECML-$E(ADELAT,6,7),ADEMPPM=ADEMPPM+(ADEINC*ADECPPM),ADEQ=1,ADESTOP=1 Q
Q
SYSET ;------->SET WATER SYS MONTHLY NODE
; FORMAT "SAMPLE COUNT^WTD AVG^IN RANGE^IN COMP"
; ^TMP is transient, non-fileman working global
S ADETPPM=ADETPPM+ADEMPPM,ADETCNT=ADETCNT+ADEMCNT
S ^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM,ADECUR)=ADEMCNT_"^"_$J((ADEMPPM/ADECML),4,1)
I ($J((ADEMPPM/ADECML),3,1)<(ADEOPT-.1))!((ADEMPPM/ADECML)>(ADEOPT+.5)) D
. S $P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM,ADECUR),"^",3)="N"
E S $P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM,ADECUR),"^",3)="Y"
I $P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM,ADECUR),"^",1)=0 D
. S $P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM,ADECUR),"^",3)=$P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM,ADECUR),"^",3)_"-"
I $P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM,ADECUR),U)>(ADECOMP-1),$P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM,ADECUR),U,3)="Y" D
. S $P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM,ADECUR),U,4)="Y"
E S $P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM,ADECUR),U,4)="N"
Q
SUSET ;------->SET SU MONTHLY NODE
;FORMAT: "IN RANGE^OUT OF RANGE^IN COMP^OUT COMP^NO SAMPL^POP IN COMP"
;
I '$D(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADECUR)) D
. S ^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADECUR)="0^0^0^0^0^0"
I $P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM,ADECUR),"^",3)["Y" D
. S $P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADECUR),"^")=$P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADECUR),"^")+1
E S $P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADECUR),"^",2)=$P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADECUR),"^",2)+1
I $P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM,ADECUR),U,4)="Y" D
. S $P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADECUR),U,3)=$P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADECUR),U,3)+1
. S $P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADECUR),U,6)=$P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADECUR),U,6)+ADEPOP
E S $P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADECUR),U,4)=$P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADECUR),U,4)+1
I $P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM,ADECUR),U)=0 D
. S $P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADECUR),U,5)=$P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADECUR),U,5)+1
Q
;
LENGTH ;EP - RETURNS LENGTH OF CURRENT MONTH
;beginning Y2K fix
;S ADECML=$E(ADECUR,4,5),ADECML=$S((ADECML="09")!(ADECML="04")!(ADECML="06")!(ADECML="11"):30,ADECML="02":$S($E(ADECUR,2,3)=88:29,1:28),1:31)
S ADECML=$E(ADECUR,4,5),ADECY=$E(ADECUR,1,3)+1700,ADELYFLG=$$LEAP^XBDT(ADECY) ;Y2000
F ADEI=1:1:12 D ;Y2000
.S ADEML(ADEI)=31 ;Y2000
.S:ADEI=2 ADEML(ADEI)=$S(ADELYFLG:29,1:28) ;Y2000
.S ADECK=","_ADEI_"," ;Y2000
.S:(",4,6,9,11,"[ADECK) ADEML(ADEI)=30 ;Y2000
S ADECML=ADEML(+ADECML) ;Y2000
K ADEML,ADEI,ADECY,ADELYFLG,ADECK ;Y2000
;end Y2K fix block
Q
ADEFPC1 ; IHS/HQT/MJL - F- COMPLIANCE PART 2 ;07:54 PM [ 03/24/1999 9:04 AM ]
+1 ;;6.0;ADE;;APRIL 1999
+2 ;
+3 SET ADEOPT=$PIECE(ADEWSNOD,"^",5)
SET ADEOPT=$SELECT(ADEOPT="A":1.2,ADEOPT="B":1.1,ADEOPT="D":.9,ADEOPT="E":.8,ADEOPT="F":.7,1:1)
+4 SET ADENAT=$PIECE(ADEWSNOD,"^",4)
+5 SET ADEPOP=$PIECE(ADEWSNOD,"^",7)
+6 ;
+7 SET (ADETDAY,ADETPPM,ADETCNT,ADELAT,ADEABS,ADESTOP)=0
+8 SET ADEBM=$EXTRACT(ADEBD,1,5)
SET ADEEM=$EXTRACT(ADEED,1,5)
+9 ;
+10 SET ADEABS=$ORDER(^ADEFLU(ADEFLDFN,1,"AB",ADEABS))
SET ADEABSMO=$EXTRACT(ADEABS,1,5)
IF ADEABS=""
QUIT
CONTROL ;------->INCREMENT FOR EACH MONTH IN REPORT
+1 FOR ADECUR=ADEBM:1
IF $EXTRACT(ADECUR,4,5)=13
SET ADECUR=ADECUR+88
IF ADECUR>ADEEM
QUIT
DO LENGTH
DO CURMO
DO SYSET
DO SUSET
DO ARSET^ADEFPC3
+2 ;------->SET SYSTEM TOTAL FOR ENTIRE DATE RANGE
+3 DO SYSTOT^ADEFPC3
END QUIT
+1 ;
+2 ;
CURMO ;------->PROCESS CURRENT MONTH ADECUR
+1 SET (ADEQ,ADEMPPM,ADEMCNT)=0
+2 IF ADESTOP
SET ADEMCNT=0
SET ADEINC=ADECML
SET ADEMPPM=ADECPPM*ADEINC
QUIT
+3 IF ADECUR<ADEABSMO
SET ADEMCNT=0
SET ADEMPPM=0
QUIT
+4 IF ADECUR=ADEABSMO
SET ADELAT=ADEABS
SET ADEMCNT=1
+5 IF '+ADELAT
DO LATEST
+6 SET ADEQ=0
FOR ADEK=0:0
SET ADENEX=$ORDER(^ADEFLU(ADEFLDFN,1,"AB",ADELAT))
SET ADENEXMO=$EXTRACT(ADENEX,1,5)
DO PPM
DO MONTH
IF ADEQ
QUIT
+7 IF ADECUR=ADEABSMO
SET ADECML=ADECML-$EXTRACT(ADEABS,6,7)
IF ADECML=0
SET ADECML=1
+8 QUIT
LATEST ;------->RETURNS DATE OF LATEST ENTRY BEFORE FIRST MONTH OF PROCESSING
+1 SET ADELAT=ADEABS
FOR ADEJ=0:0
SET ADETST=$ORDER(^ADEFLU(ADEFLDFN,1,"AB",ADELAT))
IF ADETST=""
QUIT
IF $EXTRACT(ADETST,1,5)<ADECUR
SET ADELAT=ADETST
IF ADELAT'=ADETST
QUIT
+2 QUIT
PPM ;------->RETURNS ADECPPM FOR ENTRY DATED ADELAT
+1 SET ADEX=$ORDER(^ADEFLU(ADEFLDFN,1,"AB",ADELAT,0))
SET ADECPPM=$PIECE(^ADEFLU(ADEFLDFN,1,ADEX,0),U,2)
QUIT
MONTH ;------->STEP THROUGH CURRENT MONTH ENTRIES AND CALCULATE
+1 ;---NEXT IN CURRENT MONTH, PREVIOUS ENTRY IN PREVIOUS MONTH
+2 IF ADENEXMO=ADECUR
IF $EXTRACT(ADELAT,1,5)<ADECUR
SET ADEINC=ADENEX-(ADECUR_"00")
SET ADEMPPM=ADEMPPM+(ADEINC*ADECPPM)
SET ADELAT=ADENEX
SET ADEMCNT=ADEMCNT+1
QUIT
+3 ;---NEXT AND PREVIOUS ENTRIES WITHIN THE CURRENT MONTH
+4 IF ADENEXMO=ADECUR
SET ADEINC=ADENEX-ADELAT
SET ADEMPPM=ADEMPPM+(ADEINC*ADECPPM)
SET ADELAT=ADENEX
SET ADEMCNT=ADEMCNT+1
DO PPM
QUIT
+5 ;---NEXT ENTRY IS GREATER THAN CURRENT MONTH
+6 IF ADENEXMO>ADECUR
SET ADEINC=$SELECT($EXTRACT(ADELAT,1,5)<ADECUR:ADECML,1:(ADECUR_ADECML)-ADELAT)
IF ADEINC=0
SET ADEINC=1
SET ADEMPPM=ADEMPPM+(ADEINC*ADECPPM)
SET ADEQ=1
QUIT
+7 ;---NEXT ENTRY IS NULL, PREVIOUS ENTRY IN PREVIOUS MONTH
+8 IF ADENEXMO=""
IF $EXTRACT(ADELAT,1,5)<ADECUR
SET ADEINC=ADECML
SET ADEMPPM=ADEMPPM+(ADEINC*ADECPPM)
SET ADEQ=1
SET ADESTOP=1
QUIT
+9 ;---NEXT ENTRY NULL, PREVIOUS ENTRY IN CURRENT MONTH
+10 IF ADENEXMO=""
SET ADEINC=ADECML-$EXTRACT(ADELAT,6,7)
SET ADEMPPM=ADEMPPM+(ADEINC*ADECPPM)
SET ADEQ=1
SET ADESTOP=1
QUIT
+11 QUIT
SYSET ;------->SET WATER SYS MONTHLY NODE
+1 ; FORMAT "SAMPLE COUNT^WTD AVG^IN RANGE^IN COMP"
+2 ; ^TMP is transient, non-fileman working global
+3 SET ADETPPM=ADETPPM+ADEMPPM
SET ADETCNT=ADETCNT+ADEMCNT
+4 SET ^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM,ADECUR)=ADEMCNT_"^"_$JUSTIFY((ADEMPPM/ADECML),4,1)
+5 IF ($JUSTIFY((ADEMPPM/ADECML),3,1)<(ADEOPT-.1))!((ADEMPPM/ADECML)>(ADEOPT+.5))
Begin DoDot:1
+6 SET $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM,ADECUR),"^",3)="N"
End DoDot:1
+7 IF '$TEST
SET $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM,ADECUR),"^",3)="Y"
+8 IF $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM,ADECUR),"^",1)=0
Begin DoDot:1
+9 SET $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM,ADECUR),"^",3)=$PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM,ADECUR),"^",3)_"-"
End DoDot:1
+10 IF $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM,ADECUR),U)>(ADECOMP-1)
IF $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM,ADECUR),U,3)="Y"
Begin DoDot:1
+11 SET $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM,ADECUR),U,4)="Y"
End DoDot:1
+12 IF '$TEST
SET $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM,ADECUR),U,4)="N"
+13 QUIT
SUSET ;------->SET SU MONTHLY NODE
+1 ;FORMAT: "IN RANGE^OUT OF RANGE^IN COMP^OUT COMP^NO SAMPL^POP IN COMP"
+2 ;
+3 IF '$DATA(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADECUR))
Begin DoDot:1
+4 SET ^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADECUR)="0^0^0^0^0^0"
End DoDot:1
+5 IF $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM,ADECUR),"^",3)["Y"
Begin DoDot:1
+6 SET $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADECUR),"^")=$PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADECUR),"^")+1
End DoDot:1
+7 IF '$TEST
SET $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADECUR),"^",2)=$PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADECUR),"^",2)+1
+8 IF $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM,ADECUR),U,4)="Y"
Begin DoDot:1
+9 SET $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADECUR),U,3)=$PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADECUR),U,3)+1
+10 SET $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADECUR),U,6)=$PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADECUR),U,6)+ADEPOP
End DoDot:1
+11 IF '$TEST
SET $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADECUR),U,4)=$PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADECUR),U,4)+1
+12 IF $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM,ADECUR),U)=0
Begin DoDot:1
+13 SET $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADECUR),U,5)=$PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADECUR),U,5)+1
End DoDot:1
+14 QUIT
+15 ;
LENGTH ;EP - RETURNS LENGTH OF CURRENT MONTH
+1 ;beginning Y2K fix
+2 ;S ADECML=$E(ADECUR,4,5),ADECML=$S((ADECML="09")!(ADECML="04")!(ADECML="06")!(ADECML="11"):30,ADECML="02":$S($E(ADECUR,2,3)=88:29,1:28),1:31)
+3 ;Y2000
SET ADECML=$EXTRACT(ADECUR,4,5)
SET ADECY=$EXTRACT(ADECUR,1,3)+1700
SET ADELYFLG=$$LEAP^XBDT(ADECY)
+4 ;Y2000
FOR ADEI=1:1:12
Begin DoDot:1
+5 ;Y2000
SET ADEML(ADEI)=31
+6 ;Y2000
IF ADEI=2
SET ADEML(ADEI)=$SELECT(ADELYFLG:29,1:28)
+7 ;Y2000
SET ADECK=","_ADEI_","
+8 ;Y2000
IF (",4,6,9,11,"[ADECK)
SET ADEML(ADEI)=30
End DoDot:1
+9 ;Y2000
SET ADECML=ADEML(+ADECML)
+10 ;Y2000
KILL ADEML,ADEI,ADECY,ADELYFLG,ADECK
+11 ;end Y2K fix block
+12 QUIT
