- ADEPDFR ; IHS/HQT/MJL - DEFERRED SVCS PART 1 ;07:05 PM [ 03/24/1999 9:04 AM ]
- ;;6.0;ADE;;APRIL 1999
- ;------->INIT
- I $D(DUZ(2)),DUZ(2)]""
- E W "DIVISION NOT PROPERLY SET -- CONTACT SITE MANAGER" G END
- INIT ;
- ;------->SORT CRITERIA
- ;NOTE: Add additional criteria here in future version
- W !,"You may limit the report to include only patients who were added",!,"to the Deferred Services Register during a particular time."
- S ADEBEG=$$DATE^ADEPQA3()
- G:$$HAT^ADEPQA3() END
- G:'+ADEBEG END
- S ADEEND=$P(ADEBEG,U,3),ADEBEG=$P(ADEBEG,U,2)
- ;------->DEVICE
- ;FHL 9/9/98
- ASKDEV S %ZIS="Q" D ^%ZIS G END:POP I $D(IO("Q")) K IO("Q") D QUE W:$D(ZTQUEUED) !,"REQUEST QUEUED." G END
- ZTM ;EP
- ;------->$O THRU ADEDSR("B" (TASKMAN ENTRY)
- D PROC
- ;------->PRINT
- D ^ADEPDFR1
- I $D(ZTQUEUED) S ZTREQ="@"
- K ^ADEUTIL("ADEPDFR",$J) ;^ADEUTIL is a transient working global
- ;------->END
- END K ADEAGE,ADEDFN,ADELIN,ADENAM,ADENOD,ADETOT,ADEHRN,ADEADD,ADEPAT,ADEPAG,J,ADEJ,ADEK,ADEL,ADEM,ADEGBL,ADESUB,ADESVC,ADEN,ADEBEG,ADEEND,DTOUT,DUOUT,DIROUT
- Q
- QUE S ZTRTN="ZTM^ADEPDFR",ZTDESC="DENTAL DEFERRED SVCS REPORT"
- S ZTSAVE("ADEBEG")="",ZTSAVE("ADEEND")="" ;***IHS/HMW PATCH
- D ^%ZTLOAD
- Q
- PROC S ADEPAT=""
- K ^ADEUTIL("ADEPDFR",$J)
- I '$D(IO("S")),$P(IOST,"-")="C" W !,"Please wait while I scan the records..."
- F ADEJ=0:0 S ADEPAT=$O(^ADEDSR("B",ADEPAT)) Q:'ADEPAT S ADEDFN=$O(^ADEDSR("B",ADEPAT,0)) D P3 I '$D(IO("S")),$P(IOST,"-")="C" W "."
- Q
- P3 Q:'$D(^ADEDSR(ADEDFN,0))
- Q:'$D(^ADEDSR(ADEDFN,1))
- Q:'$D(^ADEDSR(ADEDFN,2))
- S ADENOD=$P(^ADEDSR(ADEDFN,2),U)
- Q:ADENOD<ADEBEG
- Q:ADENOD>ADEEND
- S ADENOD=^ADEDSR(ADEDFN,0)
- S ADETOT=$P(ADENOD,U,2)
- S ADEHRN="MISSING"
- I $D(^AUPNPAT(+ADENOD,41,DUZ(2),0)) S ADEHRN=$P(^(0),U,2)
- Q:'$D(^DPT(+ADENOD,0))
- S ADENOD=^DPT(+ADENOD,0),ADENAM=$P(ADENOD,U),ADEAGE=$P(ADENOD,U,3)
- Q:'ADEAGE
- S X1=DT,X2=ADEAGE D ^%DTC Q:X<1
- ;beginning Y2K fix
- ;S ADEAGE=X\364.25
- S ADEAGE=X\365.25 ;Y2000
- ;S ADEADD="" I $D(^ADEDSR(ADEDFN,2)) S ADEADD=^(2),ADEADD=$E(ADEADD,4,5)_"-"_$E(ADEADD,6,7)_"-"_$E(ADEADD,2,3)
- S ADEADD="" I $D(^ADEDSR(ADEDFN,2)) S ADEADD=^(2) D:ADEADD'=""
- .S ADEYR=1700+$E(ADEADD,1,3) ;Y2000
- .S ADEADD=$E(ADEADD,4,5)_"-"_$E(ADEADD,6,7)_"-"_ADEYR ;Y2000
- .K ADEYR
- ;end Y2K fix block
- D P4
- S ADEGBL=ADENAM_U_ADEHRN_U_ADEAGE_U_ADEADD
- F ADEM=1:1:16 S $P(ADEGBL,U,ADEM+4)=ADESVC(ADEM)
- S ADEGBL=ADEGBL_U_ADETOT
- S ^ADEUTIL("ADEPDFR",$J,ADENAM,ADEDFN)=ADEGBL
- Q
- P4 Q:'$D(^ADEDSR(ADEDFN,1))
- F ADEN=1:1:16 S ADESVC(ADEN)="-"
- S ADESUB=0
- F S ADESUB=$O(^ADEDSR(ADEDFN,1,ADESUB)) Q:'+ADESUB D
- . S ADENOD=^ADEDSR(ADEDFN,1,ADESUB,0)
- . S $P(ADENOD,U)=$P(^ADEDNT(+ADENOD,0),U,2)
- . D:+ADENOD P5
- Q
- P5 S ADESVC(+ADENOD)=ADESVC(+ADENOD)+$P(ADENOD,U,2)
- Q
- ADEPDFR ; IHS/HQT/MJL - DEFERRED SVCS PART 1 ;07:05 PM [ 03/24/1999 9:04 AM ]
- +1 ;;6.0;ADE;;APRIL 1999
- +2 ;------->INIT
- +3 IF $DATA(DUZ(2))
- IF DUZ(2)]""
- +4 IF '$TEST
- WRITE "DIVISION NOT PROPERLY SET -- CONTACT SITE MANAGER"
- GOTO END
- INIT ;
- +1 ;------->SORT CRITERIA
- +2 ;NOTE: Add additional criteria here in future version
- +3 WRITE !,"You may limit the report to include only patients who were added",!,"to the Deferred Services Register during a particular time."
- +4 SET ADEBEG=$$DATE^ADEPQA3()
- +5 IF $$HAT^ADEPQA3()
- GOTO END
- +6 IF '+ADEBEG
- GOTO END
- +7 SET ADEEND=$PIECE(ADEBEG,U,3)
- SET ADEBEG=$PIECE(ADEBEG,U,2)
- +8 ;------->DEVICE
- +9 ;FHL 9/9/98
- ASKDEV SET %ZIS="Q"
- DO ^%ZIS
- IF POP
- GOTO END
- IF $DATA(IO("Q"))
- KILL IO("Q")
- DO QUE
- IF $DATA(ZTQUEUED)
- WRITE !,"REQUEST QUEUED."
- GOTO END
- ZTM ;EP
- +1 ;------->$O THRU ADEDSR("B" (TASKMAN ENTRY)
- +2 DO PROC
- +3 ;------->PRINT
- +4 DO ^ADEPDFR1
- +5 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +6 ;^ADEUTIL is a transient working global
- KILL ^ADEUTIL("ADEPDFR",$JOB)
- +7 ;------->END
- END KILL ADEAGE,ADEDFN,ADELIN,ADENAM,ADENOD,ADETOT,ADEHRN,ADEADD,ADEPAT,ADEPAG,J,ADEJ,ADEK,ADEL,ADEM,ADEGBL,ADESUB,ADESVC,ADEN,ADEBEG,ADEEND,DTOUT,DUOUT,DIROUT
- +1 QUIT
- QUE SET ZTRTN="ZTM^ADEPDFR"
- SET ZTDESC="DENTAL DEFERRED SVCS REPORT"
- +1 ;***IHS/HMW PATCH
- SET ZTSAVE("ADEBEG")=""
- SET ZTSAVE("ADEEND")=""
- +2 DO ^%ZTLOAD
- +3 QUIT
- PROC SET ADEPAT=""
- +1 KILL ^ADEUTIL("ADEPDFR",$JOB)
- +2 IF '$DATA(IO("S"))
- IF $PIECE(IOST,"-")="C"
- WRITE !,"Please wait while I scan the records..."
- +3 FOR ADEJ=0:0
- SET ADEPAT=$ORDER(^ADEDSR("B",ADEPAT))
- IF 'ADEPAT
- QUIT
- SET ADEDFN=$ORDER(^ADEDSR("B",ADEPAT,0))
- DO P3
- IF '$DATA(IO("S"))
- IF $PIECE(IOST,"-")="C"
- WRITE "."
- +4 QUIT
- P3 IF '$DATA(^ADEDSR(ADEDFN,0))
- QUIT
- +1 IF '$DATA(^ADEDSR(ADEDFN,1))
- QUIT
- +2 IF '$DATA(^ADEDSR(ADEDFN,2))
- QUIT
- +3 SET ADENOD=$PIECE(^ADEDSR(ADEDFN,2),U)
- +4 IF ADENOD<ADEBEG
- QUIT
- +5 IF ADENOD>ADEEND
- QUIT
- +6 SET ADENOD=^ADEDSR(ADEDFN,0)
- +7 SET ADETOT=$PIECE(ADENOD,U,2)
- +8 SET ADEHRN="MISSING"
- +9 IF $DATA(^AUPNPAT(+ADENOD,41,DUZ(2),0))
- SET ADEHRN=$PIECE(^(0),U,2)
- +10 IF '$DATA(^DPT(+ADENOD,0))
- QUIT
- +11 SET ADENOD=^DPT(+ADENOD,0)
- SET ADENAM=$PIECE(ADENOD,U)
- SET ADEAGE=$PIECE(ADENOD,U,3)
- +12 IF 'ADEAGE
- QUIT
- +13 SET X1=DT
- SET X2=ADEAGE
- DO ^%DTC
- IF X<1
- QUIT
- +14 ;beginning Y2K fix
- +15 ;S ADEAGE=X\364.25
- +16 ;Y2000
- SET ADEAGE=X\365.25
- +17 ;S ADEADD="" I $D(^ADEDSR(ADEDFN,2)) S ADEADD=^(2),ADEADD=$E(ADEADD,4,5)_"-"_$E(ADEADD,6,7)_"-"_$E(ADEADD,2,3)
- +18 SET ADEADD=""
- IF $DATA(^ADEDSR(ADEDFN,2))
- SET ADEADD=^(2)
- IF ADEADD'=""
- Begin DoDot:1
- +19 ;Y2000
- SET ADEYR=1700+$EXTRACT(ADEADD,1,3)
- +20 ;Y2000
- SET ADEADD=$EXTRACT(ADEADD,4,5)_"-"_$EXTRACT(ADEADD,6,7)_"-"_ADEYR
- +21 KILL ADEYR
- End DoDot:1
- +22 ;end Y2K fix block
- +23 DO P4
- +24 SET ADEGBL=ADENAM_U_ADEHRN_U_ADEAGE_U_ADEADD
- +25 FOR ADEM=1:1:16
- SET $PIECE(ADEGBL,U,ADEM+4)=ADESVC(ADEM)
- +26 SET ADEGBL=ADEGBL_U_ADETOT
- +27 SET ^ADEUTIL("ADEPDFR",$JOB,ADENAM,ADEDFN)=ADEGBL
- +28 QUIT
- P4 IF '$DATA(^ADEDSR(ADEDFN,1))
- QUIT
- +1 FOR ADEN=1:1:16
- SET ADESVC(ADEN)="-"
- +2 SET ADESUB=0
- +3 FOR
- SET ADESUB=$ORDER(^ADEDSR(ADEDFN,1,ADESUB))
- IF '+ADESUB
- QUIT
- Begin DoDot:1
- +4 SET ADENOD=^ADEDSR(ADEDFN,1,ADESUB,0)
- +5 SET $PIECE(ADENOD,U)=$PIECE(^ADEDNT(+ADENOD,0),U,2)
- +6 IF +ADENOD
- DO P5
- End DoDot:1
- +7 QUIT
- P5 SET ADESVC(+ADENOD)=ADESVC(+ADENOD)+$PIECE(ADENOD,U,2)
- +1 QUIT
