ADEFPC3 ; IHS/HQT/MJL - F- COMPLIANCE PART 3 ;04:02 PM [ 03/24/1999 9:04 AM ]
;;6.0;ADE;;APRIL 1999
SYSTOT ;EP - ------->SYSTEM & SU TOTALS
;SYSTEM TOTALS FORMAT IS "TOTAL COUNT^NATURAL^OPTIMAL^WTD AVG^SAMP/MO"
;AREA & SU TOTALS FORMAT IS "TOTAL POPULATION"
S ADETMON=$P(^TMP("ADEFPC",ADEU),U,4)
S ADECUR=ADEEM
D LENGTH^ADEFPC1
S X1=ADEEM_ADECML,X2=$S(ADEABSMO<ADEBM:ADEBM_"00",1:ADEABS)
D ^%DTC
S:ADEBM>ADEABSMO X=X+1
S ADETDAY=X
;
;SYSTEM TOTALS:
S ^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM)=ADETCNT_U_ADENAT_U_ADEOPT_U_$J((ADETPPM/ADETDAY),4,1)_U_$J((ADETCNT/ADETMON),4,1) ;^TMP is a transient report global
;SU TOTALS:
I $D(^TMP("ADEFPC",ADEU,ADEAREA,ADESU))[0 D
. S ^TMP("ADEFPC",ADEU,ADEAREA,ADESU)=0
. S $P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU),U,2)=ADESUNAM
S $P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU),U)=+^TMP("ADEFPC",ADEU,ADEAREA,ADESU)+ADEPOP
;AREA TOTALS:
I $D(^TMP("ADEFPC",ADEU,ADEAREA))[0 D
. S ^TMP("ADEFPC",ADEU,ADEAREA)=0
. S $P(^TMP("ADEFPC",ADEU,ADEAREA),U,2)=ADEARNAM
S $P(^TMP("ADEFPC",ADEU,ADEAREA),U)=+^TMP("ADEFPC",ADEU,ADEAREA)+ADEPOP
Q
;
PCOMP ;EP - CALCULATE PERCENT COMPLIANCE, SAMPLES/SYSTEM/MONTH
N ADEAREA,ADESU,ADETPOP,ADECPOP,ADEPPOP,ADESYS1,ADESYS2,ADESAM1,ADESAM2
S ADEAREA=0
F S ADEAREA=$O(^TMP("ADEFPC",ADEU,ADEAREA)) Q:ADEAREA="" D
. S ADETPOP=+^TMP("ADEFPC",ADEU,ADEAREA)
. S:ADETPOP=0 ADETPOP=1
. S ADEMO=0
. F S ADEMO=$O(^TMP("ADEFPC",ADEU,ADEAREA,"MO",ADEMO)) Q:'+ADEMO D
. . S ADECPOP=$P(^TMP("ADEFPC",ADEU,ADEAREA,"MO",ADEMO),U,6)
. . S ADEPPOP=(ADECPOP/ADETPOP)*100
. . S ADEPPOP=$J(ADEPPOP,3,0)
. . S $P(^TMP("ADEFPC",ADEU,ADEAREA,"MO",ADEMO),U,7)=ADEPPOP
S ADEAREA=0
F S ADEAREA=$O(^TMP("ADEFPC",ADEU,ADEAREA)) Q:ADEAREA="" D
. S ADESU=0
. F S ADESU=$O(^TMP("ADEFPC",ADEU,ADEAREA,ADESU)) Q:'+ADESU D
. . S ADETPOP=+^TMP("ADEFPC",ADEU,ADEAREA,ADESU)
. . S:ADETPOP=0 ADETPOP=1
. . S ADEMO=0
. . F S ADEMO=$O(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADEMO)) Q:'+ADEMO D
. . . S ADECPOP=$P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADEMO),U,6)
. . . S ADEPPOP=(ADECPOP/ADETPOP)*100
. . . S ADEPPOP=$J(ADEPPOP,3,0)
. . . S $P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADEMO),U,7)=ADEPPOP
S ADEAREA=0
F S ADEAREA=$O(^TMP("ADEFPC",ADEU,ADEAREA)) Q:ADEAREA="" D
. S ADESAM1=0,ADESYS1=0
. S ADESU=0
. F S ADESU=$O(^TMP("ADEFPC",ADEU,ADEAREA,ADESU)) Q:'+ADESU D
. . S ADESAM2=0,ADESYS2=0
. . S ADESYS=0
. . F S ADESYS=$O(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADESYS)) Q:'+ADESYS D
. . . S ADESAM2=ADESAM2+^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADESYS)
. . . S ADESYS2=ADESYS2+1
. . S $P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU),U,3)=ADESAM2
. . S $P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU),U,4)=ADESYS2
. . S $P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU),U,5)=$J((ADESAM2/ADESYS2/ADETMON),4,1)
. . S ADESAM1=ADESAM1+ADESAM2
. . S ADESYS1=ADESYS1+ADESYS2
. S $P(^TMP("ADEFPC",ADEU,ADEAREA),U,3)=ADESAM1
. S $P(^TMP("ADEFPC",ADEU,ADEAREA),U,4)=ADESYS1
. S $P(^TMP("ADEFPC",ADEU,ADEAREA),U,5)=$J((ADESAM1/ADESYS1/ADETMON),4,1)
K ADEAREA,ADESU,ADETPOP,ADECPOP,ADEPPOP,ADESYS1,ADESYS2,ADESAM1,ADESAM2
Q
;
ARSET ;EP - ------->SET AREA MONTHLY NODE
;
I '$D(^TMP("ADEFPC",ADEU,ADEAREA,"MO",ADECUR)) D
. S ^TMP("ADEFPC",ADEU,ADEAREA,"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,"MO",ADECUR),"^")=$P(^TMP("ADEFPC",ADEU,ADEAREA,"MO",ADECUR),"^")+1
E S $P(^TMP("ADEFPC",ADEU,ADEAREA,"MO",ADECUR),"^",2)=$P(^TMP("ADEFPC",ADEU,ADEAREA,"MO",ADECUR),"^",2)+1
I $P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM,ADECUR),U,4)="Y" D
. S $P(^TMP("ADEFPC",ADEU,ADEAREA,"MO",ADECUR),U,3)=$P(^TMP("ADEFPC",ADEU,ADEAREA,"MO",ADECUR),U,3)+1
. S $P(^TMP("ADEFPC",ADEU,ADEAREA,"MO",ADECUR),U,6)=$P(^TMP("ADEFPC",ADEU,ADEAREA,"MO",ADECUR),U,6)+ADEPOP
E S $P(^TMP("ADEFPC",ADEU,ADEAREA,"MO",ADECUR),U,4)=$P(^TMP("ADEFPC",ADEU,ADEAREA,"MO",ADECUR),U,4)+1
I $P(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM,ADECUR),U)=0 D
. S $P(^TMP("ADEFPC",ADEU,ADEAREA,"MO",ADECUR),U,5)=$P(^TMP("ADEFPC",ADEU,ADEAREA,"MO",ADECUR),U,5)+1
Q
ADEFPC3 ; IHS/HQT/MJL - F- COMPLIANCE PART 3 ;04:02 PM [ 03/24/1999 9:04 AM ]
+1 ;;6.0;ADE;;APRIL 1999
SYSTOT ;EP - ------->SYSTEM & SU TOTALS
+1 ;SYSTEM TOTALS FORMAT IS "TOTAL COUNT^NATURAL^OPTIMAL^WTD AVG^SAMP/MO"
+2 ;AREA & SU TOTALS FORMAT IS "TOTAL POPULATION"
+3 SET ADETMON=$PIECE(^TMP("ADEFPC",ADEU),U,4)
+4 SET ADECUR=ADEEM
+5 DO LENGTH^ADEFPC1
+6 SET X1=ADEEM_ADECML
SET X2=$SELECT(ADEABSMO<ADEBM:ADEBM_"00",1:ADEABS)
+7 DO ^%DTC
+8 IF ADEBM>ADEABSMO
SET X=X+1
+9 SET ADETDAY=X
+10 ;
+11 ;SYSTEM TOTALS:
+12 ;^TMP is a transient report global
SET ^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM)=ADETCNT_U_ADENAT_U_ADEOPT_U_$JUSTIFY((ADETPPM/ADETDAY),4,1)_U_$JUSTIFY((ADETCNT/ADETMON),4,1)
+13 ;SU TOTALS:
+14 IF $DATA(^TMP("ADEFPC",ADEU,ADEAREA,ADESU))[0
Begin DoDot:1
+15 SET ^TMP("ADEFPC",ADEU,ADEAREA,ADESU)=0
+16 SET $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU),U,2)=ADESUNAM
End DoDot:1
+17 SET $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU),U)=+^TMP("ADEFPC",ADEU,ADEAREA,ADESU)+ADEPOP
+18 ;AREA TOTALS:
+19 IF $DATA(^TMP("ADEFPC",ADEU,ADEAREA))[0
Begin DoDot:1
+20 SET ^TMP("ADEFPC",ADEU,ADEAREA)=0
+21 SET $PIECE(^TMP("ADEFPC",ADEU,ADEAREA),U,2)=ADEARNAM
End DoDot:1
+22 SET $PIECE(^TMP("ADEFPC",ADEU,ADEAREA),U)=+^TMP("ADEFPC",ADEU,ADEAREA)+ADEPOP
+23 QUIT
+24 ;
PCOMP ;EP - CALCULATE PERCENT COMPLIANCE, SAMPLES/SYSTEM/MONTH
+1 NEW ADEAREA,ADESU,ADETPOP,ADECPOP,ADEPPOP,ADESYS1,ADESYS2,ADESAM1,ADESAM2
+2 SET ADEAREA=0
+3 FOR
SET ADEAREA=$ORDER(^TMP("ADEFPC",ADEU,ADEAREA))
IF ADEAREA=""
QUIT
Begin DoDot:1
+4 SET ADETPOP=+^TMP("ADEFPC",ADEU,ADEAREA)
+5 IF ADETPOP=0
SET ADETPOP=1
+6 SET ADEMO=0
+7 FOR
SET ADEMO=$ORDER(^TMP("ADEFPC",ADEU,ADEAREA,"MO",ADEMO))
IF '+ADEMO
QUIT
Begin DoDot:2
+8 SET ADECPOP=$PIECE(^TMP("ADEFPC",ADEU,ADEAREA,"MO",ADEMO),U,6)
+9 SET ADEPPOP=(ADECPOP/ADETPOP)*100
+10 SET ADEPPOP=$JUSTIFY(ADEPPOP,3,0)
+11 SET $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,"MO",ADEMO),U,7)=ADEPPOP
End DoDot:2
End DoDot:1
+12 SET ADEAREA=0
+13 FOR
SET ADEAREA=$ORDER(^TMP("ADEFPC",ADEU,ADEAREA))
IF ADEAREA=""
QUIT
Begin DoDot:1
+14 SET ADESU=0
+15 FOR
SET ADESU=$ORDER(^TMP("ADEFPC",ADEU,ADEAREA,ADESU))
IF '+ADESU
QUIT
Begin DoDot:2
+16 SET ADETPOP=+^TMP("ADEFPC",ADEU,ADEAREA,ADESU)
+17 IF ADETPOP=0
SET ADETPOP=1
+18 SET ADEMO=0
+19 FOR
SET ADEMO=$ORDER(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADEMO))
IF '+ADEMO
QUIT
Begin DoDot:3
+20 SET ADECPOP=$PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADEMO),U,6)
+21 SET ADEPPOP=(ADECPOP/ADETPOP)*100
+22 SET ADEPPOP=$JUSTIFY(ADEPPOP,3,0)
+23 SET $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,"MO",ADEMO),U,7)=ADEPPOP
End DoDot:3
End DoDot:2
End DoDot:1
+24 SET ADEAREA=0
+25 FOR
SET ADEAREA=$ORDER(^TMP("ADEFPC",ADEU,ADEAREA))
IF ADEAREA=""
QUIT
Begin DoDot:1
+26 SET ADESAM1=0
SET ADESYS1=0
+27 SET ADESU=0
+28 FOR
SET ADESU=$ORDER(^TMP("ADEFPC",ADEU,ADEAREA,ADESU))
IF '+ADESU
QUIT
Begin DoDot:2
+29 SET ADESAM2=0
SET ADESYS2=0
+30 SET ADESYS=0
+31 FOR
SET ADESYS=$ORDER(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADESYS))
IF '+ADESYS
QUIT
Begin DoDot:3
+32 SET ADESAM2=ADESAM2+^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADESYS)
+33 SET ADESYS2=ADESYS2+1
End DoDot:3
+34 SET $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU),U,3)=ADESAM2
+35 SET $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU),U,4)=ADESYS2
+36 SET $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU),U,5)=$JUSTIFY((ADESAM2/ADESYS2/ADETMON),4,1)
+37 SET ADESAM1=ADESAM1+ADESAM2
+38 SET ADESYS1=ADESYS1+ADESYS2
End DoDot:2
+39 SET $PIECE(^TMP("ADEFPC",ADEU,ADEAREA),U,3)=ADESAM1
+40 SET $PIECE(^TMP("ADEFPC",ADEU,ADEAREA),U,4)=ADESYS1
+41 SET $PIECE(^TMP("ADEFPC",ADEU,ADEAREA),U,5)=$JUSTIFY((ADESAM1/ADESYS1/ADETMON),4,1)
End DoDot:1
+42 KILL ADEAREA,ADESU,ADETPOP,ADECPOP,ADEPPOP,ADESYS1,ADESYS2,ADESAM1,ADESAM2
+43 QUIT
+44 ;
ARSET ;EP - ------->SET AREA MONTHLY NODE
+1 ;
+2 IF '$DATA(^TMP("ADEFPC",ADEU,ADEAREA,"MO",ADECUR))
Begin DoDot:1
+3 SET ^TMP("ADEFPC",ADEU,ADEAREA,"MO",ADECUR)="0^0^0^0^0^0"
End DoDot:1
+4 IF $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM,ADECUR),"^",3)["Y"
Begin DoDot:1
+5 SET $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,"MO",ADECUR),"^")=$PIECE(^TMP("ADEFPC",ADEU,ADEAREA,"MO",ADECUR),"^")+1
End DoDot:1
+6 IF '$TEST
SET $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,"MO",ADECUR),"^",2)=$PIECE(^TMP("ADEFPC",ADEU,ADEAREA,"MO",ADECUR),"^",2)+1
+7 IF $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM,ADECUR),U,4)="Y"
Begin DoDot:1
+8 SET $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,"MO",ADECUR),U,3)=$PIECE(^TMP("ADEFPC",ADEU,ADEAREA,"MO",ADECUR),U,3)+1
+9 SET $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,"MO",ADECUR),U,6)=$PIECE(^TMP("ADEFPC",ADEU,ADEAREA,"MO",ADECUR),U,6)+ADEPOP
End DoDot:1
+10 IF '$TEST
SET $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,"MO",ADECUR),U,4)=$PIECE(^TMP("ADEFPC",ADEU,ADEAREA,"MO",ADECUR),U,4)+1
+11 IF $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,ADESU,ADEWSNAM,ADECUR),U)=0
Begin DoDot:1
+12 SET $PIECE(^TMP("ADEFPC",ADEU,ADEAREA,"MO",ADECUR),U,5)=$PIECE(^TMP("ADEFPC",ADEU,ADEAREA,"MO",ADECUR),U,5)+1
End DoDot:1
+13 QUIT
