DGMTOFA ;ALB/CAW/AEG/PWC - Future Appointments who will require MT ; 4/21/11 10:57am
;;5.3;PIMS;**3,50,182,326,426,568,725,1015,1016**;JUN 30, 2012;Build 20
;
EN ;
I '$$RANGE^DGMTUTL("F") G ENQ
I '$$DIV^DGMTUTL G ENQ
I '$$CLINIC^DGMTUTL G ENQ
;I '$$LETTER G ENQ
W !! S %ZIS="PMQ" D ^%ZIS I POP G ENQ
I '$D(IO("Q")) D MAIN G ENQ
S Y=$$QUE
ENQ ;
D:'$D(ZTQUEUED) ^%ZISC
K DFN,DGAPT,DGBEG,DGCLN,DGDATE,DGDFN,DGDIV,DGEND,DGFLG,DGINFO,DGLINE,DGLST,DGMT,DGMT1,DGPAGE,DGSTOP,DGTMP,DGTMP1,DGTMP2,DGMTYPT,DGYN,DIW,DIWF,DIWR,DIWT,DN,SDFORM,SDLET,VA,VAERR,VAUTC,VAUTD,^TMP("DGMTO",$J),^TMP("DGMTL",$J)
K DGARRAY,CLNARRAY,^TMP($J,"SDAMA"),I,DGTMP,SDCNT
Q
;
QUE() ; -- que job
; return: did job que [ 1|yes 0|no ]
;
K ZTSK,IO("Q")
S ZTDESC="Future Appt. w/ Means Test",ZTRTN="MAIN^DGMTOFA"
F X="DGBEG","DGEND","DGYN","DGMTYPT","SDFORM","SDLET","VAUTC","VAUTD","VAUTC(","VAUTD(" S ZTSAVE(X)=""
D ^%ZTLOAD W:$D(ZTSK) " (Task: ",ZTSK,")"
Q $D(ZTSK)
;
MAIN ;
K ^TMP("DGMTO",$J) S I=1
I VAUTC=1,VAUTD=1 S DGCLN=0 F S DGCLN=$O(^SC(DGCLN)) Q:'DGCLN I $P(^(DGCLN,0),U,3)="C" D CBLD3(DGCLN)
;
I VAUTC=1,VAUTD=0 S DGDIV="" F S DGDIV=$O(VAUTD(DGDIV)) Q:'DGDIV S DGCLN=0 F S DGCLN=$O(^SC(DGCLN)) Q:'DGCLN I $P(^SC(DGCLN,0),U,3)="C",$P(^SC(DGCLN,0),U,15)=DGDIV D CBLD3(DGCLN)
I VAUTC=0 S DGCLN="" F S DGCLN=$O(VAUTC(DGCLN)) Q:'DGCLN D CBLD3(DGCLN)
D SDAM,CLN1
D ^DGMTOFA1
D CLOSE^DGMTUTL
Q
;
CBLD3(DGCLN) ; Build array of specified Clinics for specified Divisions
S CLNARRAY(I)=$G(CLNARRAY(I))_DGCLN_";"
I $L(CLNARRAY(I))>120 S I=I+1
Q
;
SDAM ; Build TMP Global with Appointment API Data for Report
S DGARRAY(1)=DGBEG_";"_DGEND
S DGARRAY("FLDS")="1;3;10"
F I=1:1 Q:'$D(CLNARRAY(I)) D
.S DGARRAY(2)=CLNARRAY(I)
.I $$SDAPI^SDAMA301(.DGARRAY)>0 M ^TMP($J,"SDAMA")=^TMP($J,"SDAMA301")
.K ^TMP($J,"SDAMA301")
Q
;
CLN1 ; Loop through appointments
;
N DGTMP S DGDATE=DGBEG-.1,DGLST=DGEND+.9
S DGCLN=0 F S DGCLN=$O(^TMP($J,"SDAMA",DGCLN)) Q:'DGCLN D
.S DGDFN=0 F S DGDFN=$O(^TMP($J,"SDAMA",DGCLN,DGDFN)) Q:'DGDFN D
..S DGDATE=0 F S DGDATE=$O(^TMP($J,"SDAMA",DGCLN,DGDFN,DGDATE)) Q:'DGDATE D
...S DGTMP=^TMP($J,"SDAMA",DGCLN,DGDFN,DGDATE)
...Q:$$DOM(DGDFN,DGDATE)
...Q:"^NS^NSR^CC^CCR^CP^CPR^"[(U_$P($P(DGTMP,U,3),";")_U)
...D MT
Q
MT ; Is patient going to need to complete a MT/Copay by appt?
S DGMT=$$LST^DGMTU(DGDFN,$P(DGDATE,"."),DGMTYPT),DGMT1=$P($G(^DGMT(408.31,+DGMT,0)),U,3) I DGMT1,"^3^10^"'[("^"_DGMT1_"^") D
. N MTQ,X S MTQ=0 ; only do the following for RX Co-pay tests
.I DGMTYPT=2 D Q:MTQ=1
.. ;Exclude from report the following:
.. ;Existing RX Copay Test with Source of Test = IVM AND
.. ;Primary eligibility code = NSC OR Primary eligibility code =
.. ; SC Less than 50% and percentage is 0 and Total VA check amt = 0
.. ; DG*5.3*830
.. I $P($G(^DGMT(408.31,+DGMT,0)),U,23)'=2 Q ; quit if not IVM
.. S X=$P($G(^DPT(DGDFN,.36)),"^",1)
.. I $P($G(^DIC(8,+X,0)),"^",9)=5!($$SC(DGDFN)) S MTQ=1
.S X1=$P(DGMT,U,2),X2=365 D C^%DTC I $P(DGDATE,".")<X,$S(DGMT1=1:0,DGMT1=9:0,1:1) Q
.;Check to see if Cat C/Pend Adj agreed to pay with test date >10/5/99
.I $P(DGMT,U,2)>2991005,$P($G(^DGMT(408.31,+DGMT,0)),U,11)=1,((DGMT1=6)!(DGMT1=2)) Q
.;Check to see if Cat C, declined to provide income info but agreed to
.;pay -- no date restrictions on these types.
.I $G(DGMT1)=6,+$P($G(^DGMT(408.31,+DGMT,0)),U,14),+$P($G(^DGMT(408.31,+DGMT,0)),U,11) Q
.; checking for future means test based on DT
.N DGNXTMT
.S DGNXTMT=$O(^IVM(301.5,"AE",DGDFN,DT))
.I 'DGNXTMT S DGNXTMT=""
.S ^TMP("DGMTO",$J,$S(+$P(^SC(DGCLN,0),U,15):$P(^(0),U,15),1:$O(^DG(40.8,0))),$P(^SC(DGCLN,0),U),$P(^DPT(DGDFN,0),U),DGDATE)=DGDFN_U_$P(DGMT,U,1,4)_U_$P($P(DGTMP,U,10),";")_U_DGNXTMT,^TMP("DGMTL",$J,$P(^DPT(DGDFN,0),U),DGDFN)=""
Q
;
SC(DFN) ; Check if patient is SC 0% non-compensable
; Input -- DFN Patient IEN
; Output -- 1=Yes and 0=No
N Y
S Y=0
; Primary eligibility is SC LESS THAN 50%
I $D(^DPT(DFN,.36)),$P($G(^DIC(8,+^(.36),0)),"^",9)=3 S Y=1
G:'Y SCQ
; Service connected percentage is zero
I $P($G(^DPT(DFN,.3)),"^",2)'=0 S Y=0 G SCQ
; No Total annual VA check amount
I $P($G(^DPT(DFN,.362)),"^",20) S Y=0
SCQ Q +$G(Y)
;
LETTER() ;
; Input - none
; Output - DGYN - yes/no
;
N %
LTR W !!,"Do you want to generate letters" S %=2 D YN^DICN
;I %=1 D START^DGMTLTR S DGYN=$S('$D(DGFLG):1,1:0)
I %=2 S DGYN=0
I %=0 W !!,"Enter 'Y'es to generate letters from the listing or",!,"Enter 'N'o to produce the listing, but not the letters." G LTR
Q $D(DGYN)
;
DOM(DFN,DGT) ; Screen out dom patient
; Input: DFN - Patient IEN
; DGT - Date of visit
;
N Y,DGI,DGXFR0,DGA1,DGINP
S Y=0
D ^DGINPW I DG1 I $P(^DG(43,1,0),U,21),$D(^DIC(42,+DG1,0)),$P(^(0),U,3)="D" S Y=1
Q Y
DGMTOFA ;ALB/CAW/AEG/PWC - Future Appointments who will require MT ; 4/21/11 10:57am
+1 ;;5.3;PIMS;**3,50,182,326,426,568,725,1015,1016**;JUN 30, 2012;Build 20
+2 ;
EN ;
+1 IF '$$RANGE^DGMTUTL("F")
GOTO ENQ
+2 IF '$$DIV^DGMTUTL
GOTO ENQ
+3 IF '$$CLINIC^DGMTUTL
GOTO ENQ
+4 ;I '$$LETTER G ENQ
+5 WRITE !!
SET %ZIS="PMQ"
DO ^%ZIS
IF POP
GOTO ENQ
+6 IF '$DATA(IO("Q"))
DO MAIN
GOTO ENQ
+7 SET Y=$$QUE
ENQ ;
+1 IF '$DATA(ZTQUEUED)
DO ^%ZISC
+2 KILL DFN,DGAPT,DGBEG,DGCLN,DGDATE,DGDFN,DGDIV,DGEND,DGFLG,DGINFO,DGLINE,DGLST,DGMT,DGMT1,DGPAGE,DGSTOP,DGTMP,DGTMP1,DGTMP2,DGMTYPT,DGYN,DIW,DIWF,DIWR,DIWT,DN,SDFORM,SDLET,VA,VAERR,VAUTC,VAUTD,^TMP("DGMTO",$JOB),^TMP("DGMTL",$JOB)
+3 KILL DGARRAY,CLNARRAY,^TMP($JOB,"SDAMA"),I,DGTMP,SDCNT
+4 QUIT
+5 ;
QUE() ; -- que job
+1 ; return: did job que [ 1|yes 0|no ]
+2 ;
+3 KILL ZTSK,IO("Q")
+4 SET ZTDESC="Future Appt. w/ Means Test"
SET ZTRTN="MAIN^DGMTOFA"
+5 FOR X="DGBEG","DGEND","DGYN","DGMTYPT","SDFORM","SDLET","VAUTC","VAUTD","VAUTC(","VAUTD("
SET ZTSAVE(X)=""
+6 DO ^%ZTLOAD
IF $DATA(ZTSK)
WRITE " (Task: ",ZTSK,")"
+7 QUIT $DATA(ZTSK)
+8 ;
MAIN ;
+1 KILL ^TMP("DGMTO",$JOB)
SET I=1
+2 IF VAUTC=1
IF VAUTD=1
SET DGCLN=0
FOR
SET DGCLN=$ORDER(^SC(DGCLN))
IF 'DGCLN
QUIT
IF $PIECE(^(DGCLN,0),U,3)="C"
DO CBLD3(DGCLN)
+3 ;
+4 IF VAUTC=1
IF VAUTD=0
SET DGDIV=""
FOR
SET DGDIV=$ORDER(VAUTD(DGDIV))
IF 'DGDIV
QUIT
SET DGCLN=0
FOR
SET DGCLN=$ORDER(^SC(DGCLN))
IF 'DGCLN
QUIT
IF $PIECE(^SC(DGCLN,0),U,3)="C"
IF $PIECE(^SC(DGCLN,0),U,15)=DGDIV
DO CBLD3(DGCLN)
+5 IF VAUTC=0
SET DGCLN=""
FOR
SET DGCLN=$ORDER(VAUTC(DGCLN))
IF 'DGCLN
QUIT
DO CBLD3(DGCLN)
+6 DO SDAM
DO CLN1
+7 DO ^DGMTOFA1
+8 DO CLOSE^DGMTUTL
+9 QUIT
+10 ;
CBLD3(DGCLN) ; Build array of specified Clinics for specified Divisions
+1 SET CLNARRAY(I)=$GET(CLNARRAY(I))_DGCLN_";"
+2 IF $LENGTH(CLNARRAY(I))>120
SET I=I+1
+3 QUIT
+4 ;
SDAM ; Build TMP Global with Appointment API Data for Report
+1 SET DGARRAY(1)=DGBEG_";"_DGEND
+2 SET DGARRAY("FLDS")="1;3;10"
+3 FOR I=1:1
IF '$DATA(CLNARRAY(I))
QUIT
Begin DoDot:1
+4 SET DGARRAY(2)=CLNARRAY(I)
+5 IF $$SDAPI^SDAMA301(.DGARRAY)>0
MERGE ^TMP($JOB,"SDAMA")=^TMP($JOB,"SDAMA301")
+6 KILL ^TMP($JOB,"SDAMA301")
End DoDot:1
+7 QUIT
+8 ;
CLN1 ; Loop through appointments
+1 ;
+2 NEW DGTMP
SET DGDATE=DGBEG-.1
SET DGLST=DGEND+.9
+3 SET DGCLN=0
FOR
SET DGCLN=$ORDER(^TMP($JOB,"SDAMA",DGCLN))
IF 'DGCLN
QUIT
Begin DoDot:1
+4 SET DGDFN=0
FOR
SET DGDFN=$ORDER(^TMP($JOB,"SDAMA",DGCLN,DGDFN))
IF 'DGDFN
QUIT
Begin DoDot:2
+5 SET DGDATE=0
FOR
SET DGDATE=$ORDER(^TMP($JOB,"SDAMA",DGCLN,DGDFN,DGDATE))
IF 'DGDATE
QUIT
Begin DoDot:3
+6 SET DGTMP=^TMP($JOB,"SDAMA",DGCLN,DGDFN,DGDATE)
+7 IF $$DOM(DGDFN,DGDATE)
QUIT
+8 IF "^NS^NSR^CC^CCR^CP^CPR^"[(U_$PIECE($PIECE(DGTMP,U,3),";")_U)
QUIT
+9 DO MT
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
MT ; Is patient going to need to complete a MT/Copay by appt?
+1 SET DGMT=$$LST^DGMTU(DGDFN,$PIECE(DGDATE,"."),DGMTYPT)
SET DGMT1=$PIECE($GET(^DGMT(408.31,+DGMT,0)),U,3)
IF DGMT1
IF "^3^10^"'[("^"_DGMT1_"^")
Begin DoDot:1
+2 ; only do the following for RX Co-pay tests
NEW MTQ,X
SET MTQ=0
+3 IF DGMTYPT=2
Begin DoDot:2
+4 ;Exclude from report the following:
+5 ;Existing RX Copay Test with Source of Test = IVM AND
+6 ;Primary eligibility code = NSC OR Primary eligibility code =
+7 ; SC Less than 50% and percentage is 0 and Total VA check amt = 0
+8 ; DG*5.3*830
+9 ; quit if not IVM
IF $PIECE($GET(^DGMT(408.31,+DGMT,0)),U,23)'=2
QUIT
+10 SET X=$PIECE($GET(^DPT(DGDFN,.36)),"^",1)
+11 IF $PIECE($GET(^DIC(8,+X,0)),"^",9)=5!($$SC(DGDFN))
SET MTQ=1
End DoDot:2
IF MTQ=1
QUIT
+12 SET X1=$PIECE(DGMT,U,2)
SET X2=365
DO C^%DTC
IF $PIECE(DGDATE,".")<X
IF $SELECT(DGMT1=1:0,DGMT1=9:0,1:1)
QUIT
+13 ;Check to see if Cat C/Pend Adj agreed to pay with test date >10/5/99
+14 IF $PIECE(DGMT,U,2)>2991005
IF $PIECE($GET(^DGMT(408.31,+DGMT,0)),U,11)=1
IF ((DGMT1=6)!(DGMT1=2))
QUIT
+15 ;Check to see if Cat C, declined to provide income info but agreed to
+16 ;pay -- no date restrictions on these types.
+17 IF $GET(DGMT1)=6
IF +$PIECE($GET(^DGMT(408.31,+DGMT,0)),U,14)
IF +$PIECE($GET(^DGMT(408.31,+DGMT,0)),U,11)
QUIT
+18 ; checking for future means test based on DT
+19 NEW DGNXTMT
+20 SET DGNXTMT=$ORDER(^IVM(301.5,"AE",DGDFN,DT))
+21 IF 'DGNXTMT
SET DGNXTMT=""
+22 SET ^TMP("DGMTO",$JOB,$SELECT(+$PIECE(^SC(DGCLN,0),U,15):$PIECE(^(0),U,15),1:$ORDER(^DG(40.8,0))),$PIECE(^SC(DGCLN,0),U),$PIECE(^DPT(DGDFN,0),U),DGDATE)=DGDFN_U_$PIECE(DGMT,U,1,4)_U_$PIECE($PIECE(DGTMP,U,10),";")_U_DGNXTMT
SET ^TMP("DGMTL",$JOB,$PIECE(^DPT(DGDFN,0),U),DGDFN)=""
End DoDot:1
+23 QUIT
+24 ;
SC(DFN) ; Check if patient is SC 0% non-compensable
+1 ; Input -- DFN Patient IEN
+2 ; Output -- 1=Yes and 0=No
+3 NEW Y
+4 SET Y=0
+5 ; Primary eligibility is SC LESS THAN 50%
+6 IF $DATA(^DPT(DFN,.36))
IF $PIECE($GET(^DIC(8,+^(.36),0)),"^",9)=3
SET Y=1
+7 IF 'Y
GOTO SCQ
+8 ; Service connected percentage is zero
+9 IF $PIECE($GET(^DPT(DFN,.3)),"^",2)'=0
SET Y=0
GOTO SCQ
+10 ; No Total annual VA check amount
+11 IF $PIECE($GET(^DPT(DFN,.362)),"^",20)
SET Y=0
SCQ QUIT +$GET(Y)
+1 ;
LETTER() ;
+1 ; Input - none
+2 ; Output - DGYN - yes/no
+3 ;
+4 NEW %
LTR WRITE !!,"Do you want to generate letters"
SET %=2
DO YN^DICN
+1 ;I %=1 D START^DGMTLTR S DGYN=$S('$D(DGFLG):1,1:0)
+2 IF %=2
SET DGYN=0
+3 IF %=0
WRITE !!,"Enter 'Y'es to generate letters from the listing or",!,"Enter 'N'o to produce the listing, but not the letters."
GOTO LTR
+4 QUIT $DATA(DGYN)
+5 ;
DOM(DFN,DGT) ; Screen out dom patient
+1 ; Input: DFN - Patient IEN
+2 ; DGT - Date of visit
+3 ;
+4 NEW Y,DGI,DGXFR0,DGA1,DGINP
+5 SET Y=0
+6 DO ^DGINPW
IF DG1
IF $PIECE(^DG(43,1,0),U,21)
IF $DATA(^DIC(42,+DG1,0))
IF $PIECE(^(0),U,3)="D"
SET Y=1
+7 QUIT Y
