BHSDEN2 ;IHS/CIA/MGH - Health Summary for Dental ;17-Mar-2006 10:36;MGH
;;1.0;HEALTH SUMMARY COMPONENTS;;March 17, 2006
;===================================================================
;Taken from ADERVW2
; IHS/HQT/MJL - DENTAL CHART REVW PART 4 ; [ 03/24/1999 9:04 AM ]
;;6.0;ADE;**12**;APRIL 1999
;Health summary for dental, followup and failed appointments
;====================================================================
DO ; EP
D CKP^GMTSUP Q:$D(GMTSQIT)
FAIL I '$D(^ADEPAT(ADEPAT,"FA")) S ADETXT="<No Failed Appointments>",ADENRQ="",ADEICL=0 W ! X ADEPRT G ACTIV
S ADETXT="FAILED DENTAL APPOINTMENTS:",ADENRQ="",ADEICL=20 W ! X ADEPRT
S:'$D(ADENDM) ADENDM=10 S ADENDMS=ADENDM
;IHS/ANMC/HMW 11-1-2002 **12** Replaced next line with one following to display
;failed appts in reverse chronological order
S ADER=9999999 F S ADER=$O(^ADEPAT(ADEPAT,"FA",ADER),-1) Q:'+ADER D
.S X=$P($G(^ADEPAT(ADEPAT,"FA",ADER,0)),U)
.I +X D REGDT4^GMTSU S ADETXT=X_" "_$S($P(^ADEPAT(ADEPAT,"FA",ADER,0),U,2)="b":"BROKEN",1:"CANCELLED") S ADEICL=0,ADENRQ="" X ADEPRT S ADENDMS=ADENDMS-1 Q:'ADENDMS
ACTIV I '$D(^ADEFOL("TYPE",ADEPAT)) S ADETXT="<Not on Active Dental Followup>",ADENRQ="",ADEICL=0 W ! X ADEPRT G PREV
S ADETXT="ACTIVE DENTAL FOLLOWUP SUMMARY:",ADENRQ="",ADEICL=20 W ! X ADEPRT
S ADETYP=0 F ADEQ=0:0 S ADETYP=$O(^ADEFOL("TYPE",ADEPAT,ADETYP)) Q:ADETYP="" S ADENRQ="",ADETYPN=$S(ADETYP="w":"WAITING",ADETYP="rf":"REFERRAL",ADETYP="rc":"RECALL")_" LIST" D R2
;------->PREVIOUS FOLLOWUP
PREV I '$D(^ADEPAT(ADEPAT,"FOL")) S ADETXT="<No Previous Followup>",ADENRQ="",ADEICL=0 W ! X ADEPRT G END
S ADETXT="PREVIOUS DENTAL FOLLOWUP:",ADENRQ="",ADEICL=20 W ! X ADEPRT
S ADETXT="TYPE: ADDED: REMOVED:",ADENRQ="",ADEICL=0 X ADEPRT
S:'$D(ADENDM) ADENDM=10 S ADENDMS=ADENDM
S ADESUB=0 F ADEQ=0:0 S ADESUB=$O(^ADEPAT(ADEPAT,"FOL","B",ADESUB)) Q:'+ADESUB D P1 S ADESUBD=0 F ADEQ=0:0 S ADESUBD=$O(^ADEPAT(ADEPAT,"FOL","B",ADESUB,ADESUBD)) Q:'+ADESUBD D P2 S ADENDMS=ADENDMS-1 Q:ADENDMS=0
;
END Q
R2 S ADECAT=0 F ADEQ=0:0 S ADECAT=$O(^ADEFOL("TYPE",ADEPAT,ADETYP,ADECAT)) Q:'+ADECAT S ADETXT=$P(^ADETYP(ADECAT,0),U),ADENRQ="",ADEICL=0 D R3
Q
R3 S ADEMDFN=0 F ADEQ=0:0 S ADEMDFN=$O(^ADEFOL("TYPE",ADEPAT,ADETYP,ADECAT,ADEMDFN)) Q:'+ADEMDFN D R4
Q
R4 ;
S X=$P(^ADEFOL(ADEMDFN,0),U,3) D REGDT4^GMTSU S ADETXT=X_" "_ADETXT_" "_ADETYPN
S X=$P(^ADEFOL(ADEMDFN,0),U,4) D REGDT4^GMTSU S ADETXT=ADETXT_" Action: "_X S:$P(^ADEFOL(ADEMDFN,0),U,5)="u" ADETXT=ADETXT_" **URGENT**" X ADEPRT D:$P(^ADEFOL(ADEMDFN,0),U,6)]"" R5 Q
R5 S ADETXT="ACTION TAKEN: "_$P(^ADEFOL(ADEMDFN,0),U,6),ADEICL=15 X ADEPRT S ADEICL=0 Q
P1 S ADETXT=$P(^ADETYP(ADESUB,0),U) ;
S ADETXT=ADETXT_" "_$S($P(^ADETYP(ADESUB,0),U,4)="w":"WAITING",$P(^(0),U,4)="rc":"RECALL",$P(^(0),U,4)="rf":"REFERRAL",1:"OTHER")_" LIST"
S ADENRQ="",ADEICL=0 X ADEPRT
Q
P2 S X=$P(^ADEPAT(ADEPAT,"FOL",ADESUBD,0),U,2) D REGDT4^GMTSU S ADETXT=X
S X=$P(^ADEPAT(ADEPAT,"FOL",ADESUBD,0),U,3) D REGDT4^GMTSU S ADETXT=ADETXT_" "_X
S ADENRQ="",ADEICL=20 X ADEPRT
Q
BHSDEN2 ;IHS/CIA/MGH - Health Summary for Dental ;17-Mar-2006 10:36;MGH
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;;March 17, 2006
+2 ;===================================================================
+3 ;Taken from ADERVW2
+4 ; IHS/HQT/MJL - DENTAL CHART REVW PART 4 ; [ 03/24/1999 9:04 AM ]
+5 ;;6.0;ADE;**12**;APRIL 1999
+6 ;Health summary for dental, followup and failed appointments
+7 ;====================================================================
DO ; EP
+1 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
FAIL IF '$DATA(^ADEPAT(ADEPAT,"FA"))
SET ADETXT="<No Failed Appointments>"
SET ADENRQ=""
SET ADEICL=0
WRITE !
XECUTE ADEPRT
GOTO ACTIV
+1 SET ADETXT="FAILED DENTAL APPOINTMENTS:"
SET ADENRQ=""
SET ADEICL=20
WRITE !
XECUTE ADEPRT
+2 IF '$DATA(ADENDM)
SET ADENDM=10
SET ADENDMS=ADENDM
+3 ;IHS/ANMC/HMW 11-1-2002 **12** Replaced next line with one following to display
+4 ;failed appts in reverse chronological order
+5 SET ADER=9999999
FOR
SET ADER=$ORDER(^ADEPAT(ADEPAT,"FA",ADER),-1)
IF '+ADER
QUIT
Begin DoDot:1
+6 SET X=$PIECE($GET(^ADEPAT(ADEPAT,"FA",ADER,0)),U)
+7 IF +X
DO REGDT4^GMTSU
SET ADETXT=X_" "_$SELECT($PIECE(^ADEPAT(ADEPAT,"FA",ADER,0),U,2)="b":"BROKEN",1:"CANCELLED")
SET ADEICL=0
SET ADENRQ=""
XECUTE ADEPRT
SET ADENDMS=ADENDMS-1
IF 'ADENDMS
QUIT
End DoDot:1
ACTIV IF '$DATA(^ADEFOL("TYPE",ADEPAT))
SET ADETXT="<Not on Active Dental Followup>"
SET ADENRQ=""
SET ADEICL=0
WRITE !
XECUTE ADEPRT
GOTO PREV
+1 SET ADETXT="ACTIVE DENTAL FOLLOWUP SUMMARY:"
SET ADENRQ=""
SET ADEICL=20
WRITE !
XECUTE ADEPRT
+2 SET ADETYP=0
FOR ADEQ=0:0
SET ADETYP=$ORDER(^ADEFOL("TYPE",ADEPAT,ADETYP))
IF ADETYP=""
QUIT
SET ADENRQ=""
SET ADETYPN=$SELECT(ADETYP="w":"WAITING",ADETYP="rf":"REFERRAL",ADETYP="rc":"RECALL")_" LIST"
DO R2
+3 ;------->PREVIOUS FOLLOWUP
PREV IF '$DATA(^ADEPAT(ADEPAT,"FOL"))
SET ADETXT="<No Previous Followup>"
SET ADENRQ=""
SET ADEICL=0
WRITE !
XECUTE ADEPRT
GOTO END
+1 SET ADETXT="PREVIOUS DENTAL FOLLOWUP:"
SET ADENRQ=""
SET ADEICL=20
WRITE !
XECUTE ADEPRT
+2 SET ADETXT="TYPE: ADDED: REMOVED:"
SET ADENRQ=""
SET ADEICL=0
XECUTE ADEPRT
+3 IF '$DATA(ADENDM)
SET ADENDM=10
SET ADENDMS=ADENDM
+4 SET ADESUB=0
FOR ADEQ=0:0
SET ADESUB=$ORDER(^ADEPAT(ADEPAT,"FOL","B",ADESUB))
IF '+ADESUB
QUIT
DO P1
SET ADESUBD=0
FOR ADEQ=0:0
SET ADESUBD=$ORDER(^ADEPAT(ADEPAT,"FOL","B",ADESUB,ADESUBD))
IF '+ADESUBD
QUIT
DO P2
SET ADENDMS=ADENDMS-1
IF ADENDMS=0
QUIT
+5 ;
END QUIT
R2 SET ADECAT=0
FOR ADEQ=0:0
SET ADECAT=$ORDER(^ADEFOL("TYPE",ADEPAT,ADETYP,ADECAT))
IF '+ADECAT
QUIT
SET ADETXT=$PIECE(^ADETYP(ADECAT,0),U)
SET ADENRQ=""
SET ADEICL=0
DO R3
+1 QUIT
R3 SET ADEMDFN=0
FOR ADEQ=0:0
SET ADEMDFN=$ORDER(^ADEFOL("TYPE",ADEPAT,ADETYP,ADECAT,ADEMDFN))
IF '+ADEMDFN
QUIT
DO R4
+1 QUIT
R4 ;
+1 SET X=$PIECE(^ADEFOL(ADEMDFN,0),U,3)
DO REGDT4^GMTSU
SET ADETXT=X_" "_ADETXT_" "_ADETYPN
+2 SET X=$PIECE(^ADEFOL(ADEMDFN,0),U,4)
DO REGDT4^GMTSU
SET ADETXT=ADETXT_" Action: "_X
IF $PIECE(^ADEFOL(ADEMDFN,0),U,5)="u"
SET ADETXT=ADETXT_" **URGENT**"
XECUTE ADEPRT
IF $PIECE(^ADEFOL(ADEMDFN,0),U,6)]""
DO R5
QUIT
R5 SET ADETXT="ACTION TAKEN: "_$PIECE(^ADEFOL(ADEMDFN,0),U,6)
SET ADEICL=15
XECUTE ADEPRT
SET ADEICL=0
QUIT
P1 ;
SET ADETXT=$PIECE(^ADETYP(ADESUB,0),U)
+1 SET ADETXT=ADETXT_" "_$SELECT($PIECE(^ADETYP(ADESUB,0),U,4)="w":"WAITING",$PIECE(^(0),U,4)="rc":"RECALL",$PIECE(^(0),U,4)="rf":"REFERRAL",1:"OTHER")_" LIST"
+2 SET ADENRQ=""
SET ADEICL=0
XECUTE ADEPRT
+3 QUIT
P2 SET X=$PIECE(^ADEPAT(ADEPAT,"FOL",ADESUBD,0),U,2)
DO REGDT4^GMTSU
SET ADETXT=X
+1 SET X=$PIECE(^ADEPAT(ADEPAT,"FOL",ADESUBD,0),U,3)
DO REGDT4^GMTSU
SET ADETXT=ADETXT_" "_X
+2 SET ADENRQ=""
SET ADEICL=20
XECUTE ADEPRT
+3 QUIT
