- 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
