- 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
