ADEPSUB1 ; IHS/HQT/MJL - PRINT SUBROUTINES ; [ 08/01/2001 1:06 PM ]
;;6.0;ADE;**9**;APRIL 1999
;
DDS() ;EP - Returns "1/0"
;AND SETS UP ARRAY ADEDNAM(DFN)="DENTIST,NAME"
N ADEDDS,ADEJ
S ADEDDS=""
S ADEJ=0
F S ADEJ=$O(^DIC(6,ADEJ)) Q:'+ADEJ D
. I $D(^DIC(6,ADEJ,0)),$P(^DIC(6,ADEJ,0),U,4)]"",$D(^DIC(7,$P(^DIC(6,ADEJ,0),U,4),9999999)),+^DIC(7,$P(^DIC(6,ADEJ,0),U,4),9999999)=52 D
. . ;I ADEDDS="" S ADEDDS=ADEJ Q
. . ;S $P(ADEDDS,",",$L(ADEDDS,",")+1)=ADEJ
. . Q:'$D(^DIC(16,ADEJ,0))
. . S ADEDDS=1
. . S ADEDNAM(ADEJ)=$P(^DIC(16,ADEJ,0),U)
I ADEDDS="" Q 0
;F ADEJ=1:1:$L(ADEDDS,",") S ADEDNAM($P(ADEDDS,",",ADEJ))=$P(^DIC(16,$P(ADEDDS,",",ADEJ),0),U)
;S ADEDDS="1^"_ADEDDS
Q ADEDDS
;
HYG() ;EP - Returns "1/0^DFN,DFN,DFN"
;AND SETS UP ARRAY ADEHNAM(DFN)="HYGIENIST,NAME"
N ADEHYG,ADEJ,ADEK,ADEL
S ADEHYG=""
S ADEJ=0
F S ADEJ=$O(^DIC(6,ADEJ)) Q:'+ADEJ D
. I $D(^DIC(6,ADEJ,0)),$P(^DIC(6,ADEJ,0),U,4)]"",$D(^DIC(7,$P(^DIC(6,ADEJ,0),U,4),9999999)),+^DIC(7,$P(^DIC(6,ADEJ,0),U,4),9999999)=46 D
. . Q:'$D(^DIC(16,ADEJ,0))
. . S ADEHNAM(ADEJ)=$P(^DIC(16,ADEJ,0),U)
. . I ADEHYG="" S ADEHYG=ADEJ Q
. . S $P(ADEHYG,",",$L(ADEHYG,",")+1)=ADEJ Q
I ADEHYG="" Q 0
S ADEHYG="1^"_ADEHYG
Q ADEHYG
;
DSERIES ;EP - SETS ADESER ARRAY FOR DENTIST REPORTS
N ADEK
F ADEK="ADEPHY-V","HYG/THER DATA ENTRY CHECK" D
. S ADESER(ADEK)=$O(^ADEDIT("GRP","B",ADEK,0))
. S ADESER(ADEK)=^ADEDIT("GRP",ADESER(ADEK),1)
Q
;
HSERIES ;EP - SETS ADESER ARRAY FOR HYGIENIST REPORTS
N ADEK
F ADEK="V",0:1:4,8,9 D
. S ADESER(ADEK)=$O(^ADEDIT("GRP","B","ADEPHY-"_ADEK,0))
. S ADESER(ADEK)=^ADEDIT("GRP",ADESER(ADEK),1) ;MJL/HQT/IHS 8/31/01
Q
;
CALC4 ;EP - $O THRU ADEREP AND SET % MINUTES OF EACH SUBTOTAL NODE
;FOR REPORTS WITH 4 TIME PERIODS
N ADEJ,ADEK,ADETOTM,ADESUBM
S ADEJ=0
F S ADEJ=$O(^TMP("ADEP",ADEU,ADEJ)) Q:ADEJ="" D
. Q:'$D(^TMP("ADEP",ADEU,ADEJ,"8. TOTAL"))
. S ADETOTM=$P(^TMP("ADEP",ADEU,ADEJ,"8. TOTAL"),U,5)
. S:'ADETOTM ADETOTM=1
. S ADEK=0
. F S ADEK=$O(^TMP("ADEP",ADEU,ADEJ,ADEK)) Q:+ADEK=8 D
. . Q:'$D(^TMP("ADEP",ADEU,ADEJ,ADEK,"SUBTOTAL"))
. . S ADESUBM=$P(^TMP("ADEP",ADEU,ADEJ,ADEK,"SUBTOTAL"),U,5)
. . S $P(^TMP("ADEP",ADEU,ADEJ,ADEK,"SUBTOTAL"),U,6)=$J((ADESUBM/ADETOTM)*100,5,1)_"%" ;^TMP is a transient working global
K ADETOTM,ADESUBM,ADEJ,ADEK
Q
;
CALC3 ;EP - FOR REPORTS WITH 3 TIME PERIODS
N ADEJ,ADEK,ADETOTM,ADESUBM
S ADEJ=0
F S ADEJ=$O(^TMP("ADEP",ADEU,ADEJ)) Q:ADEJ="" D
. Q:'$D(^TMP("ADEP",ADEU,ADEJ,"8. TOTAL"))
. S ADETOTM=$P(^TMP("ADEP",ADEU,ADEJ,"8. TOTAL"),U,4)
. S:'ADETOTM ADETOTM=1
. S ADEK=0
. F S ADEK=$O(^TMP("ADEP",ADEU,ADEJ,ADEK)) Q:+ADEK=8 D
. . Q:'$D(^TMP("ADEP",ADEU,ADEJ,ADEK,"SUBTOTAL"))
. . S ADESUBM=$P(^TMP("ADEP",ADEU,ADEJ,ADEK,"SUBTOTAL"),U,4)
. . S $P(^TMP("ADEP",ADEU,ADEJ,ADEK,"SUBTOTAL"),U,5)=$J((ADESUBM/ADETOTM)*100,5,1)_"%" ;^TMP is a transient working global
K ADETOTM,ADESUBM,ADEJ,ADEK
Q
ADEPSUB1 ; IHS/HQT/MJL - PRINT SUBROUTINES ; [ 08/01/2001 1:06 PM ]
+1 ;;6.0;ADE;**9**;APRIL 1999
+2 ;
DDS() ;EP - Returns "1/0"
+1 ;AND SETS UP ARRAY ADEDNAM(DFN)="DENTIST,NAME"
+2 NEW ADEDDS,ADEJ
+3 SET ADEDDS=""
+4 SET ADEJ=0
+5 FOR
SET ADEJ=$ORDER(^DIC(6,ADEJ))
IF '+ADEJ
QUIT
Begin DoDot:1
+6 IF $DATA(^DIC(6,ADEJ,0))
IF $PIECE(^DIC(6,ADEJ,0),U,4)]""
IF $DATA(^DIC(7,$PIECE(^DIC(6,ADEJ,0),U,4),9999999))
IF +^DIC(7,$PIECE(^DIC(6,ADEJ,0),U,4),9999999)=52
Begin DoDot:2
+7 ;I ADEDDS="" S ADEDDS=ADEJ Q
+8 ;S $P(ADEDDS,",",$L(ADEDDS,",")+1)=ADEJ
+9 IF '$DATA(^DIC(16,ADEJ,0))
QUIT
+10 SET ADEDDS=1
+11 SET ADEDNAM(ADEJ)=$PIECE(^DIC(16,ADEJ,0),U)
End DoDot:2
End DoDot:1
+12 IF ADEDDS=""
QUIT 0
+13 ;F ADEJ=1:1:$L(ADEDDS,",") S ADEDNAM($P(ADEDDS,",",ADEJ))=$P(^DIC(16,$P(ADEDDS,",",ADEJ),0),U)
+14 ;S ADEDDS="1^"_ADEDDS
+15 QUIT ADEDDS
+16 ;
HYG() ;EP - Returns "1/0^DFN,DFN,DFN"
+1 ;AND SETS UP ARRAY ADEHNAM(DFN)="HYGIENIST,NAME"
+2 NEW ADEHYG,ADEJ,ADEK,ADEL
+3 SET ADEHYG=""
+4 SET ADEJ=0
+5 FOR
SET ADEJ=$ORDER(^DIC(6,ADEJ))
IF '+ADEJ
QUIT
Begin DoDot:1
+6 IF $DATA(^DIC(6,ADEJ,0))
IF $PIECE(^DIC(6,ADEJ,0),U,4)]""
IF $DATA(^DIC(7,$PIECE(^DIC(6,ADEJ,0),U,4),9999999))
IF +^DIC(7,$PIECE(^DIC(6,ADEJ,0),U,4),9999999)=46
Begin DoDot:2
+7 IF '$DATA(^DIC(16,ADEJ,0))
QUIT
+8 SET ADEHNAM(ADEJ)=$PIECE(^DIC(16,ADEJ,0),U)
+9 IF ADEHYG=""
SET ADEHYG=ADEJ
QUIT
+10 SET $PIECE(ADEHYG,",",$LENGTH(ADEHYG,",")+1)=ADEJ
QUIT
End DoDot:2
End DoDot:1
+11 IF ADEHYG=""
QUIT 0
+12 SET ADEHYG="1^"_ADEHYG
+13 QUIT ADEHYG
+14 ;
DSERIES ;EP - SETS ADESER ARRAY FOR DENTIST REPORTS
+1 NEW ADEK
+2 FOR ADEK="ADEPHY-V","HYG/THER DATA ENTRY CHECK"
Begin DoDot:1
+3 SET ADESER(ADEK)=$ORDER(^ADEDIT("GRP","B",ADEK,0))
+4 SET ADESER(ADEK)=^ADEDIT("GRP",ADESER(ADEK),1)
End DoDot:1
+5 QUIT
+6 ;
HSERIES ;EP - SETS ADESER ARRAY FOR HYGIENIST REPORTS
+1 NEW ADEK
+2 FOR ADEK="V",0:1:4,8,9
Begin DoDot:1
+3 SET ADESER(ADEK)=$ORDER(^ADEDIT("GRP","B","ADEPHY-"_ADEK,0))
+4 ;MJL/HQT/IHS 8/31/01
SET ADESER(ADEK)=^ADEDIT("GRP",ADESER(ADEK),1)
End DoDot:1
+5 QUIT
+6 ;
CALC4 ;EP - $O THRU ADEREP AND SET % MINUTES OF EACH SUBTOTAL NODE
+1 ;FOR REPORTS WITH 4 TIME PERIODS
+2 NEW ADEJ,ADEK,ADETOTM,ADESUBM
+3 SET ADEJ=0
+4 FOR
SET ADEJ=$ORDER(^TMP("ADEP",ADEU,ADEJ))
IF ADEJ=""
QUIT
Begin DoDot:1
+5 IF '$DATA(^TMP("ADEP",ADEU,ADEJ,"8. TOTAL"))
QUIT
+6 SET ADETOTM=$PIECE(^TMP("ADEP",ADEU,ADEJ,"8. TOTAL"),U,5)
+7 IF 'ADETOTM
SET ADETOTM=1
+8 SET ADEK=0
+9 FOR
SET ADEK=$ORDER(^TMP("ADEP",ADEU,ADEJ,ADEK))
IF +ADEK=8
QUIT
Begin DoDot:2
+10 IF '$DATA(^TMP("ADEP",ADEU,ADEJ,ADEK,"SUBTOTAL"))
QUIT
+11 SET ADESUBM=$PIECE(^TMP("ADEP",ADEU,ADEJ,ADEK,"SUBTOTAL"),U,5)
+12 ;^TMP is a transient working global
SET $PIECE(^TMP("ADEP",ADEU,ADEJ,ADEK,"SUBTOTAL"),U,6)=$JUSTIFY((ADESUBM/ADETOTM)*100,5,1)_"%"
End DoDot:2
End DoDot:1
+13 KILL ADETOTM,ADESUBM,ADEJ,ADEK
+14 QUIT
+15 ;
CALC3 ;EP - FOR REPORTS WITH 3 TIME PERIODS
+1 NEW ADEJ,ADEK,ADETOTM,ADESUBM
+2 SET ADEJ=0
+3 FOR
SET ADEJ=$ORDER(^TMP("ADEP",ADEU,ADEJ))
IF ADEJ=""
QUIT
Begin DoDot:1
+4 IF '$DATA(^TMP("ADEP",ADEU,ADEJ,"8. TOTAL"))
QUIT
+5 SET ADETOTM=$PIECE(^TMP("ADEP",ADEU,ADEJ,"8. TOTAL"),U,4)
+6 IF 'ADETOTM
SET ADETOTM=1
+7 SET ADEK=0
+8 FOR
SET ADEK=$ORDER(^TMP("ADEP",ADEU,ADEJ,ADEK))
IF +ADEK=8
QUIT
Begin DoDot:2
+9 IF '$DATA(^TMP("ADEP",ADEU,ADEJ,ADEK,"SUBTOTAL"))
QUIT
+10 SET ADESUBM=$PIECE(^TMP("ADEP",ADEU,ADEJ,ADEK,"SUBTOTAL"),U,4)
+11 ;^TMP is a transient working global
SET $PIECE(^TMP("ADEP",ADEU,ADEJ,ADEK,"SUBTOTAL"),U,5)=$JUSTIFY((ADESUBM/ADETOTM)*100,5,1)_"%"
End DoDot:2
End DoDot:1
+12 KILL ADETOTM,ADESUBM,ADEJ,ADEK
+13 QUIT
