- DGMTO1 ;ALB/CAW,AEG/EG - AGREED TO PAY DEDUCTIBLE PRINT (CON'T) ; 1/21/05 8:08am
- ;;5.3;Registration;**33,182,358,568,585**;Aug 13, 1993
- ;
- START ;
- ; loop through cat Cs for active ones
- S (DGPAGE,DGSTOP)=0
- F DGCAT=2,6 F DFN=0:0 S DFN=$O(^DPT("ACS",DGCAT,DFN)) Q:DFN'>0 D CATCLST
- D ACTIVE
- D CATCOUT
- K ^TMP("DGMTO",$J,"CNULL"),DFN
- D CLOSE^DGMTUTL
- Q
- ;
- CATCLST N DGDT,IEN,NODE0
- S NODE0=$G(^DPT(DFN,0)) Q:(+$G(^(.35)))!($P(NODE0,U,14)'=DGCAT)
- F DGDT=0:0 S DGDT=$O(^DGMT(408.31,"AD",1,DFN,DGDT)) Q:'DGDT S IEN=$$MTIEN^DGMTU3(1,DFN,-DGDT) I IEN,(DGDT'<DGYRAGO)&(DGDT'>DGTODAY) D
- .Q:DGCAT'[$P($G(^DGMT(408.31,+IEN,0)),U,3)
- .Q:$P($G(^DGMT(408.31,+IEN,0)),U,11)=1
- .S ^TMP("DGMTO",$J,"CNULL",$P(NODE0,U,1),DFN)=";;"_$P(NODE0,U,1)_";;"_DGCAT_";;"_$$SR^DGMTAUD1($G(^DGMT(408.31,+IEN,0)))
- QTC Q
- ;
- ACTIVE ;
- N APWHEN,I,VETARRAY,PIEN,PNAME,RCNT,ACNT,DGARRAY,SDCNT,APT,CK1,CK3,PATNAM
- S ACNT=1,RCNT=0
- S PNAME="" F S PNAME=$O(^TMP("DGMTO",$J,"CNULL",PNAME)) Q:PNAME="" D
- .S PIEN=0 F S PIEN=$O(^TMP("DGMTO",$J,"CNULL",PNAME,PIEN)) Q:'PIEN D
- ..S RCNT=RCNT+1,VETARRAY(ACNT)=$G(VETARRAY(ACNT))_PIEN_";"
- ..; Group DFNs by no more than twenty records
- ..I RCNT>19 S ACNT=ACNT+1,RCNT=0
- ;
- ; Call SD API by array of Patient DFNs
- F I=1:1 Q:'$D(VETARRAY(I)) D
- .S DGARRAY("FLDS")="1",DGARRAY(4)=VETARRAY(I)
- .S SDCNT=$$SDAPI^SDAMA301(.DGARRAY)
- .M ^TMP($J,"SDAMA")=^TMP($J,"SDAMA301")
- .K DGARRAY,^TMP($J,"SDAMA301")
- ;
- ;if there is data hanging from the 101 subscript,
- ;then it is a valid appointment, otherwise
- ;it is an error eg 01/20/2005
- ; Appointment Database was unavailable
- I $D(^TMP($J,"SDAMA",101))=1 K ^TMP("DGMTO",$J,"CNULL") S ^TMP("DGMTO",$J,"CNULL",101)="" Q
- ;
- ; Complete ^TMP entries for report
- N PATIEN,CLIEN,APPTDT,PATAPPT,APWHEN
- S PATNAM="" F S PATNAM=$O(^TMP("DGMTO",$J,"CNULL",PATNAM)) Q:PATNAM="" D
- .S PATIEN=0 F S PATIEN=$O(^TMP("DGMTO",$J,"CNULL",PATNAM,PATIEN)) Q:'PATIEN D
- ..;
- ..S CLIEN=0 F S CLIEN=$O(^TMP($J,"SDAMA",PATIEN,CLIEN)) Q:'CLIEN D
- ...S APPTDT=0 F S APPTDT=$O(^TMP($J,"SDAMA",PATIEN,CLIEN,APPTDT)) Q:'APPTDT D
- ....; Get list of appointments for vet
- ....S PATAPPT(APPTDT)=PATNAM
- ..; Update or Delete ^TMP for Report
- ..S APT=$O(^DPT(PATIEN,"DIS",(9999999-DGTODAY))),APWHEN=""
- ..I APT,(APT<(9999999-DGYRAGO)) S $P(APWHEN,U,1)="X"
- ..I +$G(^DPT(PATIEN,.105)) S $P(APWHEN,U,2)="X"
- ..I $O(PATAPPT(""),-1)>DT S $P(APWHEN,U,3)="X"
- ..K PATAPPT
- ..I APWHEN']"" D
- ...S CK1=$O(^DGPM("APRD",PATIEN,DGYRAGO)) I (+CK1)&(+CK1<DGTODAY) S $P(APWHEN,U,1)="X"
- ...S CK3=$O(^DGPM("APRD",PATIEN,DGTODAY)) I (+CK3) S $P(APWHEN,U,3)="X"
- ..S:APWHEN]"" $P(^TMP("DGMTO",$J,"CNULL",PATNAM,PATIEN),";;")=APWHEN
- ..I APWHEN']"" K ^TMP("DGMTO",$J,"CNULL",PATNAM,PATIEN)
- K ^TMP($J,"SDAMA")
- Q
- CATCOUT ;
- U IO D HDR
- I $D(^TMP("DGMTO",$J,"CNULL")) D PRINT,LEGEND Q
- W:$D(^TMP("DGMTO",$J,"CNULL",101)) !,?5,"Appointment Database is Unavailable --- Unable to generate report" Q
- W:'$D(^TMP("DGMTO",$J,"CNULL")) !,?5,"NO ACTIVE PATIENTS WHO HAVE NOT AGREED TO PAY DEDUCTIBLE",!?5," ------",!
- Q
- PRINT ;
- S DGNAME=""
- F S DGNAME=$O(^TMP("DGMTO",$J,"CNULL",DGNAME)) Q:DGNAME']"" D Q:DGSTOP
- .F DFN=0:0 S DFN=$O(^TMP("DGMTO",$J,"CNULL",DGNAME,DFN)) Q:DFN'>0 S DGX=^(DFN) D Q:DGSTOP
- ..D PID^VADPT6
- ..W !,$P(DGX,";;",2),?25,$S($P(DGX,";;",3)=2:"Pend Adj",1:"Cat. C"),?35,VA("PID"),?50,$P(DGX,";;",4),?59,$P($P(DGX,";;",1),U,1),?67,$P($P(DGX,";;",1),U,2),?75,$P($P(DGX,";;",1),U,3)
- ..D CHK
- K VA,VAPTYP,DGNAME
- Q
- ;
- HDR ;
- S DGPAGE=DGPAGE+1
- W:$E(IOST,1,2)["C-" @IOF W "Active Patients Who Have Not Agreed To Pay Deductible",?70,"Page: "_DGPAGE
- W !,"Date Range: "_$$FDATE^DGMTUTL(DGYRAGO)_" to "_$$FDATE^DGMTUTL(DGTODAY) D NOW^%DTC W ?51,"Run Date: "_$E($$FTIME^DGMTUTL(%),1,18)
- W !,""
- W !,?37,"PATIENT",?47,"MEANS TEST"
- W !,"PATIENT NAME",?25,"STATUS",?40,"ID",?49,"SOURCE",?58,"PAST",?64,"INHOUSE",?73,"FUTURE"
- S DGLINE="",$P(DGLINE,"=",IOM)=""
- W !,DGLINE
- Q
- CHK ;Check to pause on screen
- I ($Y+5)>IOSL,$E(IOST,1,2)="C-" D PAUSE S DGP=Y D:DGP HDR I 'DGP S DGSTOP=1 Q
- I $E(IOST,1,2)="P-",($Y+5)>IOSL,$O(^TMP("DGMTO",$J,DGNAME,DFN)) D HDR Q
- Q
- PAUSE ;
- W ! S DIR(0)="E" D ^DIR K DIR W !
- Q
- LEGEND ;Legend at end of report
- W !!,"ACTIVE= Sched. Admissions, Dispositions, Pt. Movements, or Clinic Appts."
- W !!,?10,"INHOUSE = Current Inpatient"
- W !,?10,"PAST = ",$$FDATE^DGMTUTL(DGYRAGO)," to ",$$FDATE^DGMTUTL(DGTODAY)
- W !,?10,"FUTURE = After ",$$FDATE^DGMTUTL(DGTODAY)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGMTO1 4530 printed Mar 13, 2025@21:49:36 Page 2
- DGMTO1 ;ALB/CAW,AEG/EG - AGREED TO PAY DEDUCTIBLE PRINT (CON'T) ; 1/21/05 8:08am
- +1 ;;5.3;Registration;**33,182,358,568,585**;Aug 13, 1993
- +2 ;
- START ;
- +1 ; loop through cat Cs for active ones
- +2 SET (DGPAGE,DGSTOP)=0
- +3 FOR DGCAT=2,6
- FOR DFN=0:0
- SET DFN=$ORDER(^DPT("ACS",DGCAT,DFN))
- if DFN'>0
- QUIT
- DO CATCLST
- +4 DO ACTIVE
- +5 DO CATCOUT
- +6 KILL ^TMP("DGMTO",$JOB,"CNULL"),DFN
- +7 DO CLOSE^DGMTUTL
- +8 QUIT
- +9 ;
- CATCLST NEW DGDT,IEN,NODE0
- +1 SET NODE0=$GET(^DPT(DFN,0))
- if (+$GET(^(.35)))!($PIECE(NODE0,U,14)'=DGCAT)
- QUIT
- +2 FOR DGDT=0:0
- SET DGDT=$ORDER(^DGMT(408.31,"AD",1,DFN,DGDT))
- if 'DGDT
- QUIT
- SET IEN=$$MTIEN^DGMTU3(1,DFN,-DGDT)
- IF IEN
- IF (DGDT'<DGYRAGO)&(DGDT'>DGTODAY)
- Begin DoDot:1
- +3 if DGCAT'[$PIECE($GET(^DGMT(408.31,+IEN,0)),U,3)
- QUIT
- +4 if $PIECE($GET(^DGMT(408.31,+IEN,0)),U,11)=1
- QUIT
- +5 SET ^TMP("DGMTO",$JOB,"CNULL",$PIECE(NODE0,U,1),DFN)=";;"_$PIECE(NODE0,U,1)_";;"_DGCAT_";;"_$$SR^DGMTAUD1($GET(^DGMT(408.31,+IEN,0)))
- End DoDot:1
- QTC QUIT
- +1 ;
- ACTIVE ;
- +1 NEW APWHEN,I,VETARRAY,PIEN,PNAME,RCNT,ACNT,DGARRAY,SDCNT,APT,CK1,CK3,PATNAM
- +2 SET ACNT=1
- SET RCNT=0
- +3 SET PNAME=""
- FOR
- SET PNAME=$ORDER(^TMP("DGMTO",$JOB,"CNULL",PNAME))
- if PNAME=""
- QUIT
- Begin DoDot:1
- +4 SET PIEN=0
- FOR
- SET PIEN=$ORDER(^TMP("DGMTO",$JOB,"CNULL",PNAME,PIEN))
- if 'PIEN
- QUIT
- Begin DoDot:2
- +5 SET RCNT=RCNT+1
- SET VETARRAY(ACNT)=$GET(VETARRAY(ACNT))_PIEN_";"
- +6 ; Group DFNs by no more than twenty records
- +7 IF RCNT>19
- SET ACNT=ACNT+1
- SET RCNT=0
- End DoDot:2
- End DoDot:1
- +8 ;
- +9 ; Call SD API by array of Patient DFNs
- +10 FOR I=1:1
- if '$DATA(VETARRAY(I))
- QUIT
- Begin DoDot:1
- +11 SET DGARRAY("FLDS")="1"
- SET DGARRAY(4)=VETARRAY(I)
- +12 SET SDCNT=$$SDAPI^SDAMA301(.DGARRAY)
- +13 MERGE ^TMP($JOB,"SDAMA")=^TMP($JOB,"SDAMA301")
- +14 KILL DGARRAY,^TMP($JOB,"SDAMA301")
- End DoDot:1
- +15 ;
- +16 ;if there is data hanging from the 101 subscript,
- +17 ;then it is a valid appointment, otherwise
- +18 ;it is an error eg 01/20/2005
- +19 ; Appointment Database was unavailable
- +20 IF $DATA(^TMP($JOB,"SDAMA",101))=1
- KILL ^TMP("DGMTO",$JOB,"CNULL")
- SET ^TMP("DGMTO",$JOB,"CNULL",101)=""
- QUIT
- +21 ;
- +22 ; Complete ^TMP entries for report
- +23 NEW PATIEN,CLIEN,APPTDT,PATAPPT,APWHEN
- +24 SET PATNAM=""
- FOR
- SET PATNAM=$ORDER(^TMP("DGMTO",$JOB,"CNULL",PATNAM))
- if PATNAM=""
- QUIT
- Begin DoDot:1
- +25 SET PATIEN=0
- FOR
- SET PATIEN=$ORDER(^TMP("DGMTO",$JOB,"CNULL",PATNAM,PATIEN))
- if 'PATIEN
- QUIT
- Begin DoDot:2
- +26 ;
- +27 SET CLIEN=0
- FOR
- SET CLIEN=$ORDER(^TMP($JOB,"SDAMA",PATIEN,CLIEN))
- if 'CLIEN
- QUIT
- Begin DoDot:3
- +28 SET APPTDT=0
- FOR
- SET APPTDT=$ORDER(^TMP($JOB,"SDAMA",PATIEN,CLIEN,APPTDT))
- if 'APPTDT
- QUIT
- Begin DoDot:4
- +29 ; Get list of appointments for vet
- +30 SET PATAPPT(APPTDT)=PATNAM
- End DoDot:4
- End DoDot:3
- +31 ; Update or Delete ^TMP for Report
- +32 SET APT=$ORDER(^DPT(PATIEN,"DIS",(9999999-DGTODAY)))
- SET APWHEN=""
- +33 IF APT
- IF (APT<(9999999-DGYRAGO))
- SET $PIECE(APWHEN,U,1)="X"
- +34 IF +$GET(^DPT(PATIEN,.105))
- SET $PIECE(APWHEN,U,2)="X"
- +35 IF $ORDER(PATAPPT(""),-1)>DT
- SET $PIECE(APWHEN,U,3)="X"
- +36 KILL PATAPPT
- +37 IF APWHEN']""
- Begin DoDot:3
- +38 SET CK1=$ORDER(^DGPM("APRD",PATIEN,DGYRAGO))
- IF (+CK1)&(+CK1<DGTODAY)
- SET $PIECE(APWHEN,U,1)="X"
- +39 SET CK3=$ORDER(^DGPM("APRD",PATIEN,DGTODAY))
- IF (+CK3)
- SET $PIECE(APWHEN,U,3)="X"
- End DoDot:3
- +40 if APWHEN]""
- SET $PIECE(^TMP("DGMTO",$JOB,"CNULL",PATNAM,PATIEN),";;")=APWHEN
- +41 IF APWHEN']""
- KILL ^TMP("DGMTO",$JOB,"CNULL",PATNAM,PATIEN)
- End DoDot:2
- End DoDot:1
- +42 KILL ^TMP($JOB,"SDAMA")
- +43 QUIT
- CATCOUT ;
- +1 USE IO
- DO HDR
- +2 IF $DATA(^TMP("DGMTO",$JOB,"CNULL"))
- DO PRINT
- DO LEGEND
- QUIT
- +3 if $DATA(^TMP("DGMTO",$JOB,"CNULL",101))
- WRITE !,?5,"Appointment Database is Unavailable --- Unable to generate report"
- QUIT
- +4 if '$DATA(^TMP("DGMTO",$JOB,"CNULL"))
- WRITE !,?5,"NO ACTIVE PATIENTS WHO HAVE NOT AGREED TO PAY DEDUCTIBLE",!?5," ------",!
- +5 QUIT
- PRINT ;
- +1 SET DGNAME=""
- +2 FOR
- SET DGNAME=$ORDER(^TMP("DGMTO",$JOB,"CNULL",DGNAME))
- if DGNAME']""
- QUIT
- Begin DoDot:1
- +3 FOR DFN=0:0
- SET DFN=$ORDER(^TMP("DGMTO",$JOB,"CNULL",DGNAME,DFN))
- if DFN'>0
- QUIT
- SET DGX=^(DFN)
- Begin DoDot:2
- +4 DO PID^VADPT6
- +5 WRITE !,$PIECE(DGX,";;",2),?25,$SELECT($PIECE(DGX,";;",3)=2:"Pend Adj",1:"Cat. C"),?35,VA("PID"),?50,$PIECE(DGX,";;",4),?59,$PIECE($PIECE(DGX,";;",1),U,1),?67,$PIECE($PIECE(DGX,";;",1),U,2),?75,$PIECE($PIECE(DGX,";;",1),U,3)
- +6 DO CHK
- End DoDot:2
- if DGSTOP
- QUIT
- End DoDot:1
- if DGSTOP
- QUIT
- +7 KILL VA,VAPTYP,DGNAME
- +8 QUIT
- +9 ;
- HDR ;
- +1 SET DGPAGE=DGPAGE+1
- +2 if $EXTRACT(IOST,1,2)["C-"
- WRITE @IOF
- WRITE "Active Patients Who Have Not Agreed To Pay Deductible",?70,"Page: "_DGPAGE
- +3 WRITE !,"Date Range: "_$$FDATE^DGMTUTL(DGYRAGO)_" to "_$$FDATE^DGMTUTL(DGTODAY)
- DO NOW^%DTC
- WRITE ?51,"Run Date: "_$EXTRACT($$FTIME^DGMTUTL(%),1,18)
- +4 WRITE !,""
- +5 WRITE !,?37,"PATIENT",?47,"MEANS TEST"
- +6 WRITE !,"PATIENT NAME",?25,"STATUS",?40,"ID",?49,"SOURCE",?58,"PAST",?64,"INHOUSE",?73,"FUTURE"
- +7 SET DGLINE=""
- SET $PIECE(DGLINE,"=",IOM)=""
- +8 WRITE !,DGLINE
- +9 QUIT
- CHK ;Check to pause on screen
- +1 IF ($Y+5)>IOSL
- IF $EXTRACT(IOST,1,2)="C-"
- DO PAUSE
- SET DGP=Y
- if DGP
- DO HDR
- IF 'DGP
- SET DGSTOP=1
- QUIT
- +2 IF $EXTRACT(IOST,1,2)="P-"
- IF ($Y+5)>IOSL
- IF $ORDER(^TMP("DGMTO",$JOB,DGNAME,DFN))
- DO HDR
- QUIT
- +3 QUIT
- PAUSE ;
- +1 WRITE !
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- WRITE !
- +2 QUIT
- LEGEND ;Legend at end of report
- +1 WRITE !!,"ACTIVE= Sched. Admissions, Dispositions, Pt. Movements, or Clinic Appts."
- +2 WRITE !!,?10,"INHOUSE = Current Inpatient"
- +3 WRITE !,?10,"PAST = ",$$FDATE^DGMTUTL(DGYRAGO)," to ",$$FDATE^DGMTUTL(DGTODAY)
- +4 WRITE !,?10,"FUTURE = After ",$$FDATE^DGMTUTL(DGTODAY)
- +5 QUIT
