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 Sep 23, 2025@20:20:54 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
