- 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
