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

DGMTA.m

Go to the documentation of this file.
  1. DGMTA ;ALB/RMO/CAW/LD/SCG/AEG/PHH/HM - Add a New Means Test;2/24/10 2:58pm
  1. ;;5.3;Registration;**33,45,137,166,177,182,290,344,332,433,458,535,612,564,688,661,840,972,996,993**;Aug 13, 1993;Build 92
  1. ;
  1. EN ;Entry point to add a new means test
  1. N DGMDOD S DGMDOD=""
  1. S DGADDF=1
  1. I $D(DGMTDFN)#2 D UNLOCK^DGMTUTL(DGMTDFN) K DGMTDFN
  1. S DIC="^DPT(",DIC(0)="AEMQ" W ! D ^DIC K DIC G Q:Y<0 S (DFN,DGMTDFN)=+Y
  1. I $P($G(^DPT(DFN,.35)),U)'="" S DGMDOD=$P(^DPT(DFN,.35),U)
  1. I $G(DGMDOD) W !,"Patient died on: ",$$FMTE^XLFDT(DGMDOD,"1D") Q
  1. ;
  1. ; check if income test in progress
  1. D CKUPLOAD^IVMCUPL(DFN)
  1. ;
  1. ; obtain lock used to synchronize local MT/CT options with income test upload
  1. I $$LOCK^DGMTUTL(DFN)
  1. ;
  1. I DGMTYPT=1 N DGDOM1 D EN^DGMTR I 'DGREQF,'$G(DGDOM1) W !,*7,"A means test can only be added for patients who require one.",! K DGDOM1 G EN
  1. ;
  1. N FUTMT S FUTMT=$$FUT^DGMTU(DFN,"",DGMTYPT) I FUTMT D FTST G EN
  1. ;
  1. ;if a test was auto-completed, DGADDF gets set to 0
  1. I 'DGADDF W !!,*7,"A means test already exists and is in effect" G EN
  1. ;
  1. K:DGMTYPT=1 DGDOM1
  1. I DGMTYPT=2 D EN^DGMTCOR I 'DGMTCOR S I=$P($T(WHY+DGWRT),";",3,99) W !!,*7,"A copay exemption test can only be added for applicable veterans.",!,I G EN
  1. S DGLDT=$$LST^DGMTU(DFN,"",DGMTYPT),DGLD=$P(DGLDT,U,2),DGLDYR=$E(DGLD,1,3)_"1231"
  1. ;
  1. DT S %DT("A")="DATE OF TEST: ",%DT="AEX",%DT(0)="-NOW",%DT("B")="NOW" W ! D ^%DT K %DT G Q:Y<0 S DGMTDT=Y
  1. I DGMTDT<$S(DGMTYPT=1:2860701,1:2921029) W !?3,*7,"The date of test cannot be before "_$S(DGMTYPT=1:"7/1/1986.",1:"10/29/1992.") G DT
  1. I DGLD,DGMTDT<DGLD W !?3,*7,"The date of test cannot be before the last date of test on " S Y=DGLD X ^DD("DD") W Y,"." G DT
  1. I DGLD S X1=DGMTDT,X2=DGLD D ^%DTC I X<365,DGMTDT'>DGLDYR D G EN
  1. .W !?3,*7,"An annual date of test already exists on " S Y=DGLD X ^DD("DD") W Y,"."
  1. .S DGTTYP=$S(DGMTYPT=1:"Means ",1:"Copay Exemption ")
  1. .W !,$S($P($G(^DG(408.34,+$P($G(^DGMT(408.31,+DGLDT,0)),U,23),0)),U)="VAMC":" Use the 'Edit an Existing "_DGTTYP_"Test' Option.",1:" Use the 'View a Past Means Test' Option.")
  1. ;
  1. ;Means Test cannot be added for patient on a DOM ward on date of test
  1. I DGMTYPT=2 G PRINT
  1. N VAINDT,VADMVT,DGDOM,DGDOM1
  1. S VAINDT=DGMTDT
  1. D DOM1^DGMTR I $G(DGDOM1) D K VAINDT,VADMVT,DGDOM,DGDOM1 G EN
  1. .W !,*7,"A Means Test cannot be added for patients on a DOM ward on date of test.",!
  1. K VAINDT,VADMVT,DGDOM,DGDOM1
  1. ;
  1. ;A warning message is displayed if last means test for patient is
  1. ;from a prior year and has a status of required. The user is given
  1. ;the option to continue or stop adding a new means test.
  1. N %
  1. I DGLD,DGMTDT>DGLDYR,$P(DGLDT,"^",4)="R" D Q:%=-1 I %=2 K % G EN
  1. .W !?3,*7,"WARNING - last means test on " S Y=DGLD X ^DD("DD") W Y," has a status of required."
  1. DT2 .W !?3,"Do you still want to continue adding new test"
  1. .S %=2 D YN^DICN
  1. .I %=0 W !?3,"Answer 'Y'es to continue adding new test." G DT2
  1. .Q
  1. K %
  1. ;
  1. PRINT I "^P^A^C^G^"[(U_$P(DGLDT,U,4)_U) S %=1 W !,"Do you wish to print the prior means test" D YN^DICN G:%=-1 Q I %Y["?" W !!,"This will print the prior means test information.",! G PRINT
  1. I $G(%)=1 S DGX=DGMTDT,DGMTDT=DGLD,DGMTI=+DGLDT,DGOPT="" D DEV^DGMTP,CLOSE^DGUTQ S DGMTDT=DGX K DGX
  1. D ADD G EN:DGMTI<0
  1. S DGMTACT="ADD",DGMTROU="EN^DGMTA" G EN^DGMTSC
  1. ;
  1. Q K DA,DFN,DGADDF,DGBL,DGFL,DGFLD,DGIRO,DGLD,DGLDT,DGLDYR,DGMTACT,DGMTCOR,DGMTDT,DGMTI,DGMTROU,DGREQF,DGTTYP,DGMTYPT,DGVI,DGVO,X,X1,X2,Y
  1. ;
  1. ; release lock used to synchronize local MT/CT options with income test upload
  1. I $D(DGMTDFN)#2 D UNLOCK^DGMTUTL(DGMTDFN) K DGMTDFN
  1. Q
  1. ;
  1. ADD ;Add means test
  1. ; Input -- DFN Patient IEN
  1. ; DGMTDT Date
  1. ; DGMTYPT Type of Test 1=MT 2=COPAY 4=LTC
  1. ; Output -- DGMTI Annual Means/Copay/LTC Test IEN
  1. N DA,DD,DIC,DIK,DINUM,DLAYGO,DO,DS,X,D0,DGSITE,CONVRT,CURIEN,LINK,DGLNKMT
  1. ;
  1. ; obtain lock used to synchronize local MT/CT options with income test upload
  1. I $$LOCK^DGMTUTL(DFN) E Q
  1. ;
  1. ; Check for Linked test and don't lose the link.
  1. S LINK="",DGLNKMT=$$LST^DGMTU(DFN,DGMTDT,DGMTYPT),CURIEN=+DGLNKMT
  1. I CURIEN D
  1. . ;Don't link test if it's in a different year (DG*5.3*661)
  1. . I $E($P(DGLNKMT,U,2),1,3)'=$E(DGMTDT,1,3) Q
  1. . S LINK=$P($G(^DGMT(408.31,CURIEN,2)),U,6)
  1. ;
  1. S DGSITE=$$GETSITE^DGMTU4(.DUZ)
  1. S X=DGMTDT,(DIC,DIK)="^DGMT(408.31,",DIC(0)="L",DLAYGO=408.31
  1. ;
  1. ;
  1. ;Look for existing IAI records and convert (if necessary)
  1. D ALL^DGMTU21(DFN,"VSD",DT,"IPR") ;ALL only returns IAI from last IY
  1. I $D(DGINC) DO
  1. . D ISCNVRT^DGMTUTL(.DGINC)
  1. ;
  1. ; The DIC("DR") string is built in this specific order so that
  1. ; all triggers and "M" x-refs fire correctly. Should not be
  1. ; modified without an in-depth review of DD of file #408.31.
  1. ;
  1. I DGMTYPT=2 D
  1. .S DIC("DR")="2////"_(DGMTYPT'=4)_";2.05////"_DGSITE_";2.06////"_LINK
  1. .S DIC("DR")=DIC("DR")_";.02////"_DFN_";.019////"_DGMTYPT
  1. .S DIC("DR")=DIC("DR")_$S('$G(SRCTST):";.23////1",1:";.23////"_SRCTST) ;DG*5.3*996
  1. E D
  1. .S DIC("DR")="2////"_(DGMTYPT'=4)_";2.05////"_DGSITE_";2.06////"_LINK
  1. .S DIC("DR")=DIC("DR")_";.019////"_DGMTYPT_";.02////"_DFN
  1. .S DIC("DR")=DIC("DR")_$S('$G(SRCTST):";.23////1",1:";.23////"_SRCTST) ;DG*5.3*996
  1. K DD,DO
  1. D FILE^DICN S DGMTI=+Y
  1. ;
  1. ; Check for another test in the current year and convert IAI records if needed
  1. ; Send new test date (as test that have) into VRCHKUP
  1. I $D(TYPE),((+TYPE=1)!(TYPE=4)) S CONVRT=$$VRCHKUP^DGMTU2(DGMTYPT,TYPE,DGMTDT)
  1. I $D(TYPE),((+TYPE'=1)&(TYPE'=4)) S CONVRT=$$VRCHKUP^DGMTU2(DGMTYPT,,DGMTDT)
  1. I '$D(TYPE) S CONVRT=$$VRCHKUP^DGMTU2(DGMTYPT,,DGMTDT)
  1. N DGERR,DGMTRT
  1. S DGMTRT(408.31,DGMTI_",",2.11)=1
  1. S DGERR=""
  1. D FILE^DIE("","DGMTRT",DGERR)
  1. ; release lock used to synchronize local MT/CT options with income test upload
  1. D UNLOCK^DGMTUTL(DFN)
  1. ;
  1. ADDQ Q
  1. ;
  1. FTST ; Build message for future tests that are added to the system, but
  1. ; were not performed by the VAMC trying to add a new MT.
  1. N SITE,DGMTYPT,DGTTYP,SRC,SCT
  1. S SCT=$P(^DGMT(408.31,+FUTMT,2),U,5),SITE=$$INST^DGENU()
  1. S DGMTYPT=$P(^DGMT(408.31,+FUTMT,0),U,19)
  1. S DGTTYP=$S(DGMTYPT=1:"Means ",1:"Copay Exemption ")
  1. W !?3,*7,"A future test already exists on "
  1. S Y=$P(FUTMT,U,2) X ^DD("DD") W Y,"."
  1. ; This site performed the MT
  1. I SITE=SCT D
  1. .W !?3,"Use the 'Edit an Existing "_DGTTYP_"Test' Option."
  1. ;
  1. ; The MT was added by another VAMC
  1. I SITE'=SCT D
  1. .S SRC=$P(FUTMT,U,5)
  1. .I SCT W !?3,"The "_DGTTYP_"Test was conducted at Site: ",SCT
  1. .W !?3,"Please contact "
  1. .W $S($D(^DIC(4,+SCT,0)):$P(^DIC(4,+SCT,0),U),SRC=2:"IVM",SRC=3:"the HEC",1:"the site")
  1. .W ",",!?3,"if it is necessary to edit the test."
  1. Q
  1. ; HM DG*5.3*972 - added Medal of Honor to list of reasons
  1. ; DSB DG*5.3*993- added Registration only
  1. WHY ;Why Copay Test cannot be added
  1. ;;Patient is not a veteran.
  1. ;;Patient does not have a Primary Eligibility Code.
  1. ;;Patient is Service Connected 50-100%.
  1. ;;Means Test options must be used instead of Copay options.
  1. ;;Patient is receiving Aid and Attendance, automatically exempted.
  1. ;;Patient is receiving Housebound Benefits, automatically exempted.
  1. ;;Patient is receiving a VA Pension, automatically exempted.
  1. ;;Patient is in a DOM ward, automatically exempted.
  1. ;;Patient is an inpatient, automatically exempted.
  1. ;;Patient was a POW, automatically exempted.
  1. ;;Patient is Unemployable, automatically exempted.
  1. ;;Patient is Catastrophically Disabled, automatically exempted.
  1. ;;Patient is awarded Medal of Honor, automatically exempted.
  1. ;;Patient's Enrollment Status is REGISTRATION ONLY.