ADERVW2 ; IHS/HQT/MJL - DENTAL CHART REVW PART 4 ; [ 03/24/1999 9:04 AM ]
;;6.0;ADE;**12**;APRIL 1999
;S DUZ=99 D ^XBKVAR D I2^ADERVW
X ADECKP Q:$D(APCHSQIT) X:'APCHSNPG ADEBRK
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=0 F ADEQ=0:0 S ADER=$O(^ADEPAT(ADEPAT,"FA",ADER)) Q:'+ADER S Y=$P(^ADEPAT(ADEPAT,"FA",ADER,0),U) X ADECVD S ADETXT=Y_" "_$S($P(^(0),U,2)="b":"BROKEN",1:"CANCELLED") S ADEICL=0,ADENRQ="" X ADEPRT S ADENDMS=ADENDMS-1 Q:'ADENDMS
S ADER=9999999 F S ADER=$O(^ADEPAT(ADEPAT,"FA",ADER),-1) Q:'+ADER S Y=$P($G(^ADEPAT(ADEPAT,"FA",ADER,0)),U) I +Y X ADECVD S ADETXT=Y_" "_$S($P(^(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 Y=$P(^ADEFOL(ADEMDFN,0),U,3) X ADECVD S ADETXT=Y_" "_ADETXT_" "_ADETYPN S:$P(^(0),U,5)="u" ADETXT=ADETXT_" **URGENT**" X ADEPRT D:$P(^(0),U,6)]"" R5 Q ;ADETXT=ADETXT_" ACTION TAKEN: "_$P(^(0),U,6) X ADEPRT Q
S Y=$P(^ADEFOL(ADEMDFN,0),U,3) X ADECVD S ADETXT=Y_" "_ADETXT_" "_ADETYPN S Y=$P(^ADEFOL(ADEMDFN,0),U,4) X ADECVD S ADETXT=ADETXT_" Action: "_Y S:$P(^(0),U,5)="u" ADETXT=ADETXT_" **URGENT**" X ADEPRT D:$P(^(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 Y=$P(^ADEPAT(ADEPAT,"FOL",ADESUBD,0),U,2) X ADECVD S ADETXT=Y
S Y=$P(^ADEPAT(ADEPAT,"FOL",ADESUBD,0),U,3) X ADECVD S ADETXT=ADETXT_" "_Y
S ADENRQ="",ADEICL=20 X ADEPRT
Q
EN ;EP ------->ENTRY POINT FOR FOLLOWUP REVIEW OPTION
;S ADEPCC=0 D PATLK^ADERVW G:Y<1 END
N ADEPCC,ADEPAT
S ADEPCC=0
S ADEPAT=1
K DIC S DIC="^AUPNPAT(",DIC(0)="AEQMZ" D ^DIC
I Y<1 G ENEND
S ADEPAT=+Y
ASKDEV ;FHL 9/9/98 S %ZIS="Q" D ^%ZIS G:POP ENEND I $D(IO("Q")) K IO("Q") D QUE W:$D(ZTSK) !,"REQUEST QUEUED!" G ENEND
S %ZIS="Q" D ^%ZIS G:POP ENEND I $D(IO("Q")) K IO("Q") D QUE W:$D(ZTQUEUED) !,"REQUEST QUEUED!" G ENEND
ZTM D I2^ADERVW D FAIL D END^ADERVW
ENEND Q
QUE S ZTRTN="ZTM^ADERVW2",ZTDESC="DENTAL FOLLOWUP INQUIRY",ZTSAVE("ADEPAT")="",ZTSAVE("ADEPCC")="" D ^%ZTLOAD Q
ADERVW2 ; IHS/HQT/MJL - DENTAL CHART REVW PART 4 ; [ 03/24/1999 9:04 AM ]
+1 ;;6.0;ADE;**12**;APRIL 1999
+2 ;S DUZ=99 D ^XBKVAR D I2^ADERVW
+3 XECUTE ADECKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE ADEBRK
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 ;S ADER=0 F ADEQ=0:0 S ADER=$O(^ADEPAT(ADEPAT,"FA",ADER)) Q:'+ADER S Y=$P(^ADEPAT(ADEPAT,"FA",ADER,0),U) X ADECVD S ADETXT=Y_" "_$S($P(^(0),U,2)="b":"BROKEN",1:"CANCELLED") S ADEICL=0,ADENRQ="" X ADEPRT S ADENDMS=ADENDMS-1 Q:'ADENDMS
+6 SET ADER=9999999
FOR
SET ADER=$ORDER(^ADEPAT(ADEPAT,"FA",ADER),-1)
IF '+ADER
QUIT
SET Y=$PIECE($GET(^ADEPAT(ADEPAT,"FA",ADER,0)),U)
IF +Y
XECUTE ADECVD
SET ADETXT=Y_" "_$SELECT($PIECE(^(0),U,2)="b":"BROKEN",1:"CANCELLED")
SET ADEICL=0
SET ADENRQ=""
XECUTE ADEPRT
SET ADENDMS=ADENDMS-1
IF 'ADENDMS
QUIT
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 ;S Y=$P(^ADEFOL(ADEMDFN,0),U,3) X ADECVD S ADETXT=Y_" "_ADETXT_" "_ADETYPN S:$P(^(0),U,5)="u" ADETXT=ADETXT_" **URGENT**" X ADEPRT D:$P(^(0),U,6)]"" R5 Q ;ADETXT=ADETXT_" ACTION TAKEN: "_$P(^(0),U,6) X ADEPRT Q
+1 SET Y=$PIECE(^ADEFOL(ADEMDFN,0),U,3)
XECUTE ADECVD
SET ADETXT=Y_" "_ADETXT_" "_ADETYPN
SET Y=$PIECE(^ADEFOL(ADEMDFN,0),U,4)
XECUTE ADECVD
SET ADETXT=ADETXT_" Action: "_Y
IF $PIECE(^(0),U,5)="u"
SET ADETXT=ADETXT_" **URGENT**"
XECUTE ADEPRT
IF $PIECE(^(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 Y=$PIECE(^ADEPAT(ADEPAT,"FOL",ADESUBD,0),U,2)
XECUTE ADECVD
SET ADETXT=Y
+1 SET Y=$PIECE(^ADEPAT(ADEPAT,"FOL",ADESUBD,0),U,3)
XECUTE ADECVD
SET ADETXT=ADETXT_" "_Y
+2 SET ADENRQ=""
SET ADEICL=20
XECUTE ADEPRT
+3 QUIT
EN ;EP ------->ENTRY POINT FOR FOLLOWUP REVIEW OPTION
+1 ;S ADEPCC=0 D PATLK^ADERVW G:Y<1 END
+2 NEW ADEPCC,ADEPAT
+3 SET ADEPCC=0
+4 SET ADEPAT=1
+5 KILL DIC
SET DIC="^AUPNPAT("
SET DIC(0)="AEQMZ"
DO ^DIC
+6 IF Y<1
GOTO ENEND
+7 SET ADEPAT=+Y
ASKDEV ;FHL 9/9/98 S %ZIS="Q" D ^%ZIS G:POP ENEND I $D(IO("Q")) K IO("Q") D QUE W:$D(ZTSK) !,"REQUEST QUEUED!" G ENEND
+1 SET %ZIS="Q"
DO ^%ZIS
IF POP
GOTO ENEND
IF $DATA(IO("Q"))
KILL IO("Q")
DO QUE
IF $DATA(ZTQUEUED)
WRITE !,"REQUEST QUEUED!"
GOTO ENEND
ZTM DO I2^ADERVW
DO FAIL
DO END^ADERVW
ENEND QUIT
QUE SET ZTRTN="ZTM^ADERVW2"
SET ZTDESC="DENTAL FOLLOWUP INQUIRY"
SET ZTSAVE("ADEPAT")=""
SET ZTSAVE("ADEPCC")=""
DO ^%ZTLOAD
QUIT
