ADEPSUB3 ; IHS/HQT/MJL - PRINT SUBROUTINES ; [ 08/01/2001 1:08 PM ]
;;6.0;ADE;**9,15**;JAN 01, 2004
;
;$O Thru code subfile & increment counter for each code series
;Build ADEREP for ADEPER periods
;The array we're building is:
;ADEREP(DENTIST NAME,SERIES,CODE)="Week1 total,...week4total"
;AND ADEREP(DENTIST NAME,SERIES,"TOTAL")
;Where DENTIST NAME is printable name and:
; CODE SERIES= Visits, Diagnostics, Preventive, Restorative, etc
;
HSCREEN(ADEDFN,ADEPER) ;EP - HYGIENIST/THERAPIST REPORTS
N ADENOD,ADEVDT,ADEJ,ADECODM
S ADENOD=^ADEPCD(ADEDFN,0)
S ADEVDT=$P(ADENOD,U,2)
Q:'$$HYGSCN^ADEPQA1C(ADENOD)
S ADEJ=0 F S ADEJ=$O(^ADEPCD(ADEDFN,"ADA",ADEJ)) Q:'+ADEJ D
. N ADECOD,ADECNOD,ADEK,ADEWK
. S ADECNOD=^ADEPCD(ADEDFN,"ADA",ADEJ,0)
. Q:$P(ADECNOD,U,5)]"" ;Unreportable code
. S ADECOD=^AUTTADA($P(ADECNOD,U),0)
. ;----- BEGIN IHS MODIFICATIONS ADE*6.0*15
. S ADECODRV=$P($G(^AUTTADA($P(ADECNOD,U),5)),U) ;RELATIVE VALUE UNIT
. ;----- END IHS MODIFICATIONS
. S ADECODM=$P(ADECOD,U,4)
. S ADECOD=$P(ADECOD,U)
. S ADESER=""
. F ADEK="V",0:1:4,8,9 I ADESER(ADEK)[ADECOD D Q ;MJL/HQT/IHS 8/31/01
. . S ADESER=$S(ADEK="V":"1.PERSONS SERVED",ADEK="0":"2.DIAGNOSTICS",ADEK=1:"3.PREVENTIVE",ADEK=2:"4.RESTORATIVE",ADEK=3:"5.ENDODONTIC",ADEK=4:"6.PERIODONTIC",ADEK=7:"71.SURGICAL",ADEK=8:"72.ORTHO",ADEK=9:"73.OTHER",1:"")
. I ADESER="",$E(ADECOD,1,1)=5!($E(ADECOD,1,1)=6),ADECOD'=6923 D
. . S ADESER="7.PROSTHODONTIC"
. Q:ADESER=""
. I ADEPER=3 D SETREP3^ADEPSUB4(ADEHNAM($P(ADENOD,U,5)))
. I ADEPER=4 D SETREP4^ADEPSUB4(ADEHNAM($P(ADENOD,U,5)))
Q
;
DSCREEN(ADEDFN,ADEPER) ;EP - DENTIST REPORTS
N ADENOD,ADEVDT,ADEJ,ADECODM
S ADENOD=^ADEPCD(ADEDFN,0)
S ADEVDT=$P(ADENOD,U,2)
S ADEJ=0 F S ADEJ=$O(^ADEPCD(ADEDFN,"ADA",ADEJ)) Q:'+ADEJ D
. N ADECOD,ADECNOD,ADEK,ADEWK,ADECODM
. S ADECNOD=^ADEPCD(ADEDFN,"ADA",ADEJ,0)
. Q:$P(ADECNOD,U,5)]"" ;Unreportable code
. S ADECOD=^AUTTADA($P(ADECNOD,U),0)
. ;----- BEGIN IHS MODIFICATIONS ADE*6.0*15
. S ADECODRV=$P($G(^AUTTADA($P(ADECNOD,U),5)),U) ;RELATIVE VALUE UNIT
. ;----- END IHS MODIFICATIONS
. S ADECODM=$P(ADECOD,U,4)
. S ADECOD=$P(ADECOD,U)
. I +ADEHYG,ADESER("HYG/THER DATA ENTRY CHECK")[ADECOD,$$HYGSCN^ADEPQA1C(ADENOD) Q
. S ADESER=""
. D
. . I ADESER("ADEPHY-V")[ADECOD S ADESER="1.PERSONS SERVED" Q
. . I $E(ADECOD,1,1)=0 S ADESER="2.DIAGNOSTICS" Q
. . I $E(ADECOD,1,1)=1 S ADESER="3.PREVENTIVE" Q
. . I $E(ADECOD,1,1)=2!(ADECOD=6973) S ADESER="4.RESTORATIVE" Q
. . I $E(ADECOD,1,1)=3 S ADESER="5.ENDODONTIC" Q
. . I $E(ADECOD,1,1)=4 S ADESER="6.PERIODONTIC" Q
. . I $E(ADECOD,1,1)=5!($E(ADECOD,1,1)=6) S ADESER="7.PROSTHODONTIC" Q
. . I $E(ADECOD,1,1)=7!(ADECOD=9930) S ADESER="71.SURGICAL" Q
. . I $E(ADECOD,1,1)=8 S ADESER="72.ORTHO" Q
. . S ADESER="73.OTHER SERVICES" Q
. Q:ADESER=""
. I ADEPER=3 D SETREP3^ADEPSUB4(ADEDNAM($P(ADENOD,U,4)))
. I ADEPER=4 D SETREP4^ADEPSUB4(ADEDNAM($P(ADENOD,U,4)))
Q
ADEPSUB3 ; IHS/HQT/MJL - PRINT SUBROUTINES ; [ 08/01/2001 1:08 PM ]
+1 ;;6.0;ADE;**9,15**;JAN 01, 2004
+2 ;
+3 ;$O Thru code subfile & increment counter for each code series
+4 ;Build ADEREP for ADEPER periods
+5 ;The array we're building is:
+6 ;ADEREP(DENTIST NAME,SERIES,CODE)="Week1 total,...week4total"
+7 ;AND ADEREP(DENTIST NAME,SERIES,"TOTAL")
+8 ;Where DENTIST NAME is printable name and:
+9 ; CODE SERIES= Visits, Diagnostics, Preventive, Restorative, etc
+10 ;
HSCREEN(ADEDFN,ADEPER) ;EP - HYGIENIST/THERAPIST REPORTS
+1 NEW ADENOD,ADEVDT,ADEJ,ADECODM
+2 SET ADENOD=^ADEPCD(ADEDFN,0)
+3 SET ADEVDT=$PIECE(ADENOD,U,2)
+4 IF '$$HYGSCN^ADEPQA1C(ADENOD)
QUIT
+5 SET ADEJ=0
FOR
SET ADEJ=$ORDER(^ADEPCD(ADEDFN,"ADA",ADEJ))
IF '+ADEJ
QUIT
Begin DoDot:1
+6 NEW ADECOD,ADECNOD,ADEK,ADEWK
+7 SET ADECNOD=^ADEPCD(ADEDFN,"ADA",ADEJ,0)
+8 ;Unreportable code
IF $PIECE(ADECNOD,U,5)]""
QUIT
+9 SET ADECOD=^AUTTADA($PIECE(ADECNOD,U),0)
+10 ;----- BEGIN IHS MODIFICATIONS ADE*6.0*15
+11 ;RELATIVE VALUE UNIT
SET ADECODRV=$PIECE($GET(^AUTTADA($PIECE(ADECNOD,U),5)),U)
+12 ;----- END IHS MODIFICATIONS
+13 SET ADECODM=$PIECE(ADECOD,U,4)
+14 SET ADECOD=$PIECE(ADECOD,U)
+15 SET ADESER=""
+16 ;MJL/HQT/IHS 8/31/01
FOR ADEK="V",0:1:4,8,9
IF ADESER(ADEK)[ADECOD
Begin DoDot:2
+17 SET ADESER=$SELECT(ADEK="V":"1.PERSONS SERVED",ADEK="0":"2.DIAGNOSTICS",ADEK=1:"3.PREVENTIVE",ADEK=2:"4.RESTORATIVE",ADEK=3:"5.ENDODONTIC",ADEK=4:"6.PERIODONTIC",ADEK=7:"71.SURGICAL",ADEK=8:"72.ORTHO",ADEK=9:"73.OTHER",1:"")
End DoDot:2
QUIT
+18 IF ADESER=""
IF $EXTRACT(ADECOD,1,1)=5!($EXTRACT(ADECOD,1,1)=6)
IF ADECOD'=6923
Begin DoDot:2
+19 SET ADESER="7.PROSTHODONTIC"
End DoDot:2
+20 IF ADESER=""
QUIT
+21 IF ADEPER=3
DO SETREP3^ADEPSUB4(ADEHNAM($PIECE(ADENOD,U,5)))
+22 IF ADEPER=4
DO SETREP4^ADEPSUB4(ADEHNAM($PIECE(ADENOD,U,5)))
End DoDot:1
+23 QUIT
+24 ;
DSCREEN(ADEDFN,ADEPER) ;EP - DENTIST REPORTS
+1 NEW ADENOD,ADEVDT,ADEJ,ADECODM
+2 SET ADENOD=^ADEPCD(ADEDFN,0)
+3 SET ADEVDT=$PIECE(ADENOD,U,2)
+4 SET ADEJ=0
FOR
SET ADEJ=$ORDER(^ADEPCD(ADEDFN,"ADA",ADEJ))
IF '+ADEJ
QUIT
Begin DoDot:1
+5 NEW ADECOD,ADECNOD,ADEK,ADEWK,ADECODM
+6 SET ADECNOD=^ADEPCD(ADEDFN,"ADA",ADEJ,0)
+7 ;Unreportable code
IF $PIECE(ADECNOD,U,5)]""
QUIT
+8 SET ADECOD=^AUTTADA($PIECE(ADECNOD,U),0)
+9 ;----- BEGIN IHS MODIFICATIONS ADE*6.0*15
+10 ;RELATIVE VALUE UNIT
SET ADECODRV=$PIECE($GET(^AUTTADA($PIECE(ADECNOD,U),5)),U)
+11 ;----- END IHS MODIFICATIONS
+12 SET ADECODM=$PIECE(ADECOD,U,4)
+13 SET ADECOD=$PIECE(ADECOD,U)
+14 IF +ADEHYG
IF ADESER("HYG/THER DATA ENTRY CHECK")[ADECOD
IF $$HYGSCN^ADEPQA1C(ADENOD)
QUIT
+15 SET ADESER=""
+16 Begin DoDot:2
+17 IF ADESER("ADEPHY-V")[ADECOD
SET ADESER="1.PERSONS SERVED"
QUIT
+18 IF $EXTRACT(ADECOD,1,1)=0
SET ADESER="2.DIAGNOSTICS"
QUIT
+19 IF $EXTRACT(ADECOD,1,1)=1
SET ADESER="3.PREVENTIVE"
QUIT
+20 IF $EXTRACT(ADECOD,1,1)=2!(ADECOD=6973)
SET ADESER="4.RESTORATIVE"
QUIT
+21 IF $EXTRACT(ADECOD,1,1)=3
SET ADESER="5.ENDODONTIC"
QUIT
+22 IF $EXTRACT(ADECOD,1,1)=4
SET ADESER="6.PERIODONTIC"
QUIT
+23 IF $EXTRACT(ADECOD,1,1)=5!($EXTRACT(ADECOD,1,1)=6)
SET ADESER="7.PROSTHODONTIC"
QUIT
+24 IF $EXTRACT(ADECOD,1,1)=7!(ADECOD=9930)
SET ADESER="71.SURGICAL"
QUIT
+25 IF $EXTRACT(ADECOD,1,1)=8
SET ADESER="72.ORTHO"
QUIT
+26 SET ADESER="73.OTHER SERVICES"
QUIT
End DoDot:2
+27 IF ADESER=""
QUIT
+28 IF ADEPER=3
DO SETREP3^ADEPSUB4(ADEDNAM($PIECE(ADENOD,U,4)))
+29 IF ADEPER=4
DO SETREP4^ADEPSUB4(ADEDNAM($PIECE(ADENOD,U,4)))
End DoDot:1
+30 QUIT
