Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGMTOFA

DGMTOFA.m

Go to the documentation of this file. 
  1. DGMTOFA ;ALB/CAW/AEG/PWC/DHS - Future Appointments who will require MT ; 4/21/11 10:57am
  1.  ;;5.3;Registration;**3,50,182,326,426,568,725,830,891**;Aug 13, 1993;Build 14
  1.  ;
  1. EN ; 
  1.  I '$$RANGE^DGMTUTL("F") G ENQ
  1.  I '$$DIV^DGMTUTL G ENQ
  1.  I '$$CLINIC^DGMTUTL G ENQ
  1.  ;I '$$LETTER G ENQ
  1.  W !! S %ZIS="PMQ" D ^%ZIS I POP G ENQ
  1.  I '$D(IO("Q")) D MAIN G ENQ
  1.  S Y=$$QUE
  1. ENQ ;
  1.  D:'$D(ZTQUEUED) ^%ZISC
  1.  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)
  1.  K DGARRAY,CLNARRAY,^TMP($J,"SDAMA"),I,DGTMP,SDCNT
  1.  Q
  1.  ;
  1. QUE() ; -- que job
  1.  ; return: did job que [ 1|yes   0|no ]
  1.  ;
  1.  K ZTSK,IO("Q")
  1.  S ZTDESC="Future Appt. w/ Means Test",ZTRTN="MAIN^DGMTOFA"
  1.  F X="DGBEG","DGEND","DGYN","DGMTYPT","SDFORM","SDLET","VAUTC","VAUTD","VAUTC(","VAUTD(" S ZTSAVE(X)=""
  1.  D ^%ZTLOAD W:$D(ZTSK) "   (Task: ",ZTSK,")"
  1.  Q $D(ZTSK)
  1.  ;
  1. MAIN ; 
  1.  K ^TMP("DGMTO",$J) S I=1
  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)
  1.  ;
  1.  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)
  1.  I VAUTC=0 S DGCLN="" F  S DGCLN=$O(VAUTC(DGCLN)) Q:'DGCLN  D CBLD3(DGCLN)
  1.  D SDAM,CLN1
  1.  D ^DGMTOFA1
  1.  D CLOSE^DGMTUTL
  1.  Q
  1.  ;
  1. CBLD3(DGCLN) ; Build array of specified Clinics for specified Divisions
  1.  S CLNARRAY(I)=$G(CLNARRAY(I))_DGCLN_";"
  1.  I $L(CLNARRAY(I))>120 S I=I+1
  1.  Q
  1.  ;
  1. SDAM ; Build TMP Global with Appointment API Data for Report
  1.  S DGARRAY(1)=DGBEG_";"_DGEND
  1.  S DGARRAY("FLDS")="1;3;10"
  1.  F I=1:1 Q:'$D(CLNARRAY(I))  D
  1.  .S DGARRAY(2)=CLNARRAY(I)
  1.  .I $$SDAPI^SDAMA301(.DGARRAY)>0 M ^TMP($J,"SDAMA")=^TMP($J,"SDAMA301")
  1.  .K ^TMP($J,"SDAMA301")
  1.  Q
  1.  ;
  1. CLN1 ; Loop through appointments
  1.  ;
  1.  N DGTMP S DGDATE=DGBEG-.1,DGLST=DGEND+.9
  1.  S DGCLN=0 F  S DGCLN=$O(^TMP($J,"SDAMA",DGCLN)) Q:'DGCLN  D
  1.  .S DGDFN=0 F  S DGDFN=$O(^TMP($J,"SDAMA",DGCLN,DGDFN)) Q:'DGDFN  D
  1.  ..S DGDATE=0 F  S DGDATE=$O(^TMP($J,"SDAMA",DGCLN,DGDFN,DGDATE)) Q:'DGDATE  D
  1.  ...S DGTMP=^TMP($J,"SDAMA",DGCLN,DGDFN,DGDATE)
  1.  ...Q:$$DOM(DGDFN,DGDATE)
  1.  ...Q:"^NS^NSR^CC^CCR^CP^CPR^"[(U_$P($P(DGTMP,U,3),";")_U)
  1.  ...D MT
  1.  Q
  1. MT ; Is patient going to need to complete a MT/Copay by appt?
  1.   S DGMT=$$LST^DGMTU(DGDFN,$P(DGDATE,"."),DGMTYPT),DGMT1=$P($G(^DGMT(408.31,+DGMT,0)),U,3) I DGMT1,"^3^10^"'[("^"_DGMT1_"^") D
  1.  . N MTQ,X S MTQ=0  ; only do the following for RX Co-pay tests
  1.  .I DGMTYPT=2 D  Q:MTQ=1
  1.  .. ;Exclude from report the following:
  1.  .. ;Existing RX Copay Test with Source of Test = IVM AND
  1.  .. ;Primary eligibility code = NSC OR Primary eligibility code =
  1.  .. ; SC Less than 50% and percentage is 0 and Total VA check amt = 0
  1.  .. ;  DG*5.3*830
  1.  .. I $P($G(^DGMT(408.31,+DGMT,0)),U,23)'=2 Q  ; quit if not IVM
  1.  .. S X=$P($G(^DPT(DGDFN,.36)),"^",1)
  1.  .. I $P($G(^DIC(8,+X,0)),"^",9)=5!($$SC(DGDFN)) S MTQ=1
  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
  1.  .;Check to see if Cat C/Pend Adj agreed to pay with test date >10/5/99
  1.  .I $P(DGMT,U,2)>2991005,$P($G(^DGMT(408.31,+DGMT,0)),U,11)=1,((DGMT1=6)!(DGMT1=2)) Q
  1.  .;Check to see if Cat C, declined to provide income info but agreed to
  1.  .;pay -- no date restrictions on these types.
  1.  .I $G(DGMT1)=6,+$P($G(^DGMT(408.31,+DGMT,0)),U,14),+$P($G(^DGMT(408.31,+DGMT,0)),U,11) Q
  1.  .; checking for future means test based on DT
  1.  .;
  1.  .; DG*5.3*891 - test whether patient is current
  1.  .I $P(DGMT,U,2)>3120101&($P(DGMT,U,2)<3130101) Q  ; test effective date range   1 or 9 value
  1.  .I $P(DGMT,U,2)>3121231,"^4^11^16^"[("^"_DGMT1_"^") Q  ; MT status = Copay exempt,GMT Copay requred,Pending Adjudication
  1.  .I DGMT1=6!(DGMT1=3) Q  ;MT Copay required and and No longer required
  1.  .;
  1.  .N DGNXTMT
  1.  .S DGNXTMT=$O(^IVM(301.5,"AE",DGDFN,DT))
  1.  .I 'DGNXTMT S DGNXTMT=""
  1.  .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)=""
  1.  Q
  1.  ;
  1. SC(DFN) ; Check if patient is SC 0% non-compensable
  1.  ; Input -- DFN       Patient IEN
  1.  ; Output -- 1=Yes and 0=No
  1.  N Y
  1.  S Y=0
  1.  ; Primary eligibility is SC LESS THAN 50%
  1.  I $D(^DPT(DFN,.36)),$P($G(^DIC(8,+^(.36),0)),"^",9)=3 S Y=1
  1.  G:'Y SCQ
  1.  ; Service connected percentage is zero
  1.  I $P($G(^DPT(DFN,.3)),"^",2)'=0 S Y=0 G SCQ
  1.  ; No Total annual VA check amount
  1.  I $P($G(^DPT(DFN,.362)),"^",20) S Y=0
  1. SCQ Q +$G(Y)
  1.  ;
  1. LETTER() ;
  1.  ;   Input - none
  1.  ;  Output - DGYN - yes/no
  1.  ;
  1.  N %
  1. LTR W !!,"Do you want to generate letters" S %=2 D YN^DICN
  1.  ;I %=1 D START^DGMTLTR S DGYN=$S('$D(DGFLG):1,1:0)
  1.  I %=2 S DGYN=0
  1.  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
  1.  Q $D(DGYN)
  1.  ;
  1. DOM(DFN,DGT) ; Screen out dom patient
  1.  ;         Input:   DFN - Patient IEN
  1.  ;                  DGT - Date of visit
  1.  ;
  1.  N Y,DGI,DGXFR0,DGA1,DGINP
  1.  S Y=0
  1.  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
  1.  Q Y