DGBTALTI ;PAV - BENEFICIARY/TRAVEL Alternate Income Enter/Edit ; 4/23/2012@1130
;;1.0;Beneficiary Travel;**20,24,39**;September 25, 2001;Build 6
ALT ;BT Alternate Income Enter/Edit
D KILL S DGBTIME=300 S:'$D(DTIME) DTIME=DGBTIME S:'$D(U) U="^"
I '$D(DT)#2 S %DT="",S="T" D ^%DT S DT=Y
PATIENT ; patient lookup, quit if patient doesn't exist
D QUIT1^DGBTEND ; kill local variables except med division vars
S DGBTDTI=DT
S DGBTTOUT="",DIC="^DPT(",DIC(0)="AEQMZ",DIC("A")="Select PATIENT: "
W !!,"BT Alternate Income Enter/Edit" D ^DIC K DIC G:+Y'>0 EXITE
; get patient information#
S DFN=+Y
L +^DGBT(392.9,DFN):3
E W !,*7,"Somebody else is Editing this entry",*7 G EXIT
D 6^VADPT,KVAR^DGBTEND,PID^VADPT ;
I '+VAEL(1) W !!,"Eligibility is missing from registration and is required to continue.",*7 G EXIT
D GA^DGBTUTL(DFN,"XX(3)",DT,"XX(5)") ;W !! ZW XX W !
I $D(XX(5,1))!(XX(3)) D W ! G:$G(EXIT) EXIT
.W ! S DIR("A")="<D>isplay Income History, or <C>ontinue with current Alt. Income: ",DIR(0)="SA^;D:Display;C:Continue",DIR("B")="C" D ^DIR
.I Y=U!($G(DUOUT)) S EXIT=1 Q
.Q:Y="C"
.W !!,"History of Alt. Incomes:" S I=0
.F S I=$O(XX(5,I)) Q:'I W !,I,": ",$$FMTE^XLFDT($P(XX(5,I),U,3)),?30,"$",$P(XX(5,I),U,2),?40,$S($P(XX(5,I),U,4)="H":"Hardship",1:"POW"),?50,"Ex: ",$$FMTE^XLFDT($P(XX(5,I),U,5))
.W:XX(3) !,"*",": ",$$FMTE^XLFDT($P(XX(3),U,3)),?30,"$",$P(XX(3),U,2),?40,$S($P(XX(3),U,4)="H":"Hardship",1:"POW"),?50,"Ex: ",$$FMTE^XLFDT($P(XX(3),U,5))
DATE ;Get the date
K DIR S DIR("A")="Begin Date",DIR("B")=$$FMTE^XLFDT(DT),DIR(0)="D^"_$$FMADD^XLFDT(DT,-30)_":DT:EA"
D ^DIR G:(Y=U)!$G(DTOUT)!$G(DUOUT) EXIT
S DGBTDTI=Y,DGBTDTY=" (Year: "_$$FMTE^XLFDT($E(DGBTDTI,1,3)_"0000")_")"
S XXX(3)=XX(3) K XX D PI(DFN,DGBTDTI,.XX) S XX(3)=XXX(3)
D PD S TXT=""
RD ;Display - Redisplay Alt. Income on File
I XX(3) W !!,*7 S:'$L(TXT) TXT=$$FMTE^XLFDT($P(XX(3),U,3))_": $"_$P(XX(3),U,2)_" Alternate income is on the File" W TXT D G:EXIT EXIT G RD
.I $$FMDIFF^XLFDT(DT,$P(XX(3),U,3))>30 W !!,"No Edit permited for Alt. Income older as 30 days." S EXIT=1 Q
.S EXIT=0,TXT=""
.K DIR S DIR("A")="<D>elete Alt. Income, <E>dit Alt. Income, or <Q>uit ",DIR("B")="Quit",DIR(0)="SA^D:Delete;E:Edit;Q:Quit" D ^DIR
.I Y="Q"!(Y=U) S EXIT=1 Q
.I Y="E" S X=$$SETINC(DFN,$P(XX(3),U,3),DGBTDTI) D GA^DGBTUTL(DFN,"XX(3)",DGBTDTI),PD S TXT=$$FMTE^XLFDT($P(XX(3),U,3))_": Alt. Income "_$S($P(XX(3),U,4)="H":"Hardship",1:"POW")_": $"_$P(XX(3),U,2)_" has been Saved " Q
.I Y="D" S DA(1)=DFN,DA=$P(XX(3),U,3),DIK="^DGBT(392.9,DFN,1," D ^DIK W !,"Alternate Income Deleted" S EXIT=1
I XX(1) W !!,"Patient Already Qualified for Low Income Condition",*7 G EXIT
W:XX(4) !!,"This is the POW Patient",*7
W !
RD1 W !,"Continue Processing Alternate Income" S %=1 D YN^DICN
I %=2!(%=-1) G EXIT
I '% W !," Answer with 'Yes' or 'No'",*7 G RD1
I $$SETINC(DFN,,DGBTDTI) S DA(1)=DFN,DA=DGBTDTI,DIK="^DGBT(392.9,DFN,1," D ^DIK W !,"Alternate Income Deleted" G EXIT
D GA^DGBTUTL(DFN,"XX(3)",DGBTDTI),PD
I XX(3) W !!,$S($P(XX(3),U,4)="H":"Hardship",1:"POW")_": $",$P(XX(3),U,2)," Begin: ",$$FMTE^XLFDT($P(XX(3),U,3))," Expire: ",$$FMTE^XLFDT($P(XX(3),U,5))," has been Saved "
G EXIT
Q
SETINC(DFN,OLDDATE,DGBTDTI) ;Set Alt Income
N DIE,DR,Y,FDA,DA
I $G(OLDDATE) S DA(1)=DFN,DA=OLDDATE,DIK="^DGBT(392.9,DFN,1," D ^DIK
I '$D(^DGBT(392.9,DFN,0)) S IENC(1)=DFN S FDA(392.9,"+1,",.01)=IENC(1) D UPDATE^DIE(,"FDA","IENC")
K IENC S IENC(2)=DGBTDTI,FDA(392.91,"+2,"_DFN_",",.01)=IENC(2) D UPDATE^DIE(,"FDA","IENC","DGBTERR")
W !,"Begin of Alt. Income: ",$$FMTE^XLFDT(DGBTDTI)
K DIR S DIR("A")="Enter the Alternate Income",DIR(0)="392.91,1"
I $L($P($G(XX(3)),U,2)) S DIR("B")=$P($G(XX(3)),U,2),DIR(0)="392.91,1"
E S DIR(0)="392.91,1A",DIR("A")=DIR("A")_": "
D ^DIR
Q:Y=U!$G(DTOUT) 1 ;$S($P($G(XX(3)),U,2):0,1:1)
S FDA(392.91,DGBTDTI_","_DFN_",",1)=Y
K DIR S DIR("A")="Enter the Reason for Alternate Income: "
I XX(4) S DIR("B")="P",DIR(0)="SA^P:POW;H:Hardship"
E S DIR("B")="H",DIR(0)="SA^H:Hardship"
D ^DIR
I Y=U!$G(DTOUT) Q 1
S FDA(392.91,DGBTDTI_","_DFN_",",2)=Y
S FDA(392.91,DGBTDTI_","_DFN_",",3)=$S(Y="H":$E(DGBTDTI,1,3)_1231,1:$E(DGBTDTI,1,3)+1_$E(DGBTDTI,4,7))
D FILE^DIE(,"FDA")
Q 0
PI(DFN,DGBTDTI,XX) ;Return Patient info in XX
;XX(1)=Already Low Income on Record
;XX(2)=Hardship on Record <== Discontinued
;XX(3)=Alt Income is on file 1^$Alt Inc^Date^Reason^Exp Date
;XX(4)=POW on file
;XX(5)=Expired Alt Income on file (list) XX(5,I)=Date^income^reason^expiration date
N X0,X1,FDA K XX
S DGBTDEP=$$DEP^VAFMON(DFN,DGBTDTI)
S DGBTMTTH=$$MTTH^DGBTMTTH(DGBTDEP,DGBTDTI) ; Means test threshold
S DGBTRXTH=+$$THRES^IBARXEU1(DGBTDTI,1,DGBTDEP) ; RX co-pay threshhold
S X0=+$$LI^DGBTUTL(DFN,DGBTDTI,DGBTDEP,1)
S XX(1)=$S("1^2"[X0:1,1:0)
;S XX(2)=$S(X0=3:1,1:0)
D GA^DGBTUTL(DFN,"XX(3)",DGBTDTI,"XX(5)")
D SVC^VADPT
S XX(4)=+$G(VASV(4))
Q:XX(4)
;VAEL(1)="15^HOUSEBOUND"
;VAEL(1,18)="18^PRISONER OF WAR"
I VAEL(1)["PRISONER OF WAR" S XX(4)=1
F S X0=$O(VAEL(1,X0)) Q:'X0 I VAEL(1,X0)["PRISONER OF WAR" S XX(4)=1 Q
Q
PD ;Display patient information
W @IOF
D PID^VADPT6,RESADDR^DGBTUTL1(.DGBTADDR) W !!?8,"Name: ",VADM(1),?40,"PT ID: ",VA("PID"),?64,"DOB: ",$P(VADM(3),"^",2)
W !!?5,"Address: ",DGBTADDR(1) W:DGBTADDR(2)]"" !?14,DGBTADDR(2)
W:DGBTADDR(3)]"" !?14,DGBTADDR(3) W !?14,DGBTADDR(4),$S(DGBTADDR(4)]"":", "_$P(DGBTADDR(5),"^",2)_" "_$P(DGBTADDR(6),"^",2),1:"UNSPECIFIED") ;*39 - updated to use residential address
; if move in current info for elig, sc%
S DGBTELG=VAEL(1),DGBTCSC=VAEL(3)
I +DGBTELG=3,'$E(DGBTCSC)=1 S DGBTCSC=1
W !!," Eligibility: ",$P(DGBTELG,"^",2) W:DGBTCSC ?45,"SC%: ",$P(DGBTCSC,"^",2) W ?65,"POW:",$S(XX(4):"YES",1:"NO") W !
I $O(VAEL(1,0))'="" W !," Other Elig.: " F I=0:0 S I=$O(VAEL(1,I)) Q:'I W ?14,$P(VAEL(1,I),"^",2)," "
; service connected status/information
I DGBTCSC&($P(DGBTCSC,"^",2)'>29) W !!,"Disabilities:" S I3=""
N DGQUIT,I
F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I!($G(DGQUIT)=1) D
. S I1=^(I,0),I2=$S($D(^DIC(31,+I1,0)):$P(^(0),"^",1)_" ("_+$P(I1,"^",2)_"%-"_$S($P(I1,"^",3):"SC",1:"NSC")_")",1:""),I3=I1
. I $Y>(IOSL-3) D PAUSE I $G(DGQUIT)=0 W @IOF
. I $G(DGQUIT)=1 Q
. W ?16 W I2,!
;;;
D:XX(3)
.N X,X2,X3
.S X=$P(XX(3),U,2),DGBTIFL=$E($P(XX(3),U,4)) ; returns income & source.
.I X?1N.E!(X<0) D
.I X<0 S X=0
.S X2="0$",X3=8 D COMMA^%DTC
.S DGBTINC=X_U_$G(DGBTIFL)
S DGBTDT=DGBTDTI,DGBTINCA=XX(3)
I $$DAYSTEST^DGBT1(DFN,.DAYFLG,.RXDAYS,.RXCPST,.LOWINC,.DGNOTEST)
; Inserted PATCH 24
I $$MTCHK^DGBTUTL1(DFN,DGBTDT)>0 D
. S (DAYFLG,DGBTDYFL)=1
S X=$$LST^DGMTCOU1(DFN,DT,3),DGBTMTS=$P(X,U,4)_U_$P(X,U,3)
S:XX(3) RXCPST=0,DGBTMTS=U,DAYFLG=1 ; PAVEL
;I DAYFLG,$G(RXCPST),$G(RXCP)'=1 S DGBTINC="^",DGBTIFL=""
I DAYFLG,$G(RXCPST) S DGBTIFL="C" S:DGBTMTS]"" DGBTMTS=U S:$G(RXCP)'=1 DGBTINC="^"
I 'DAYFLG S DGBTINC="^",DGBTIFL="^",DGBTMTS="EX^"
W !!?2,"Income: ",$P($G(DGBTINC),U),$G(DGBTDTY),?35,"Source of Income: "
W $S($G(DGBTIFL)="M":"MEANS TEST",$G(DGBTIFL)="C":"COPAY TEST",$G(DGBTIFL)="P":"Alt. Income POW",$G(DGBTIFL)="H":"Alt. Income Hardship",1:"")
I XX(3) W !,?40," (Expire: ",$$FMTE^XLFDT($P(XX(3),U,5)),")"
W !?2,"No. of Dependents: ",+DGBTDEP
I DGBTMTS]"" W:$P(DGBTMTS,"^")'="N" ?35,"MT Status: ",$S($P(DGBTMTS,"^")="EX":"EXPIRED",$P(DGBTMTS,"^")="R":"REQUIRED",$P(DGBTMTS,"^")="P":$P($P(DGBTMTS,"^",2)," "),DGBTMTS=U!($G(RXCPST)):" NOT APPLICABLE",1:$P(DGBTMTS,"^",2))
;
Q
PAUSE ;added with DGBT*1*11
I $E(IOST,1,2)["C-" N DIR S DIR(0)="E" D ^DIR S DGQUIT='Y
Q
EXIT ;Exit patient
I $G(DFN) L -^DGBT(392.9,DFN)
W !!,"EXITING Patient" D KILL G ALT
Q
EXITE ; Exit Menu
I $G(DFN) L -^DGBT(392.9,DFN)
W !!,"EXITING Alternate Income Menu" D KILL
Q
KILL ;Kill Local variable.. Dont use NEW, because of return to Patient Prompt
K DGBTTOUT,DGBTAI,DGBTAIE,DGBTR,DGBTHAR,DGBTELG,VAEL,DGBTCSC,VAPA,VASV,DGBTDEP,DGBTIFL,DGBTINC,IENC,DGBTDTI,DGBTERR,DGBTMTS,DGBTDTY,TXT
K DGBTINCA,DAYFLG,RXDAYS,RXCPST,LOWINC,DGNOTEST,RXCP,DDD
K X,Y,I,I1,I2,I3,X2,DFN,DIC,Y,EXP,DA,DR,DIE,FDA,XX,XXX,DIR,EXIT,%DT,DGBTADDR ;*39 kill dgbtaddr
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGBTALTI 8213 printed Dec 13, 2024@01:40:24 Page 2
DGBTALTI ;PAV - BENEFICIARY/TRAVEL Alternate Income Enter/Edit ; 4/23/2012@1130
+1 ;;1.0;Beneficiary Travel;**20,24,39**;September 25, 2001;Build 6
ALT ;BT Alternate Income Enter/Edit
+1 DO KILL
SET DGBTIME=300
if '$DATA(DTIME)
SET DTIME=DGBTIME
if '$DATA(U)
SET U="^"
+2 IF '$DATA(DT)#2
SET %DT=""
SET S="T"
DO ^%DT
SET DT=Y
PATIENT ; patient lookup, quit if patient doesn't exist
+1 ; kill local variables except med division vars
DO QUIT1^DGBTEND
+2 SET DGBTDTI=DT
+3 SET DGBTTOUT=""
SET DIC="^DPT("
SET DIC(0)="AEQMZ"
SET DIC("A")="Select PATIENT: "
+4 WRITE !!,"BT Alternate Income Enter/Edit"
DO ^DIC
KILL DIC
if +Y'>0
GOTO EXITE
+5 ; get patient information#
+6 SET DFN=+Y
+7 LOCK +^DGBT(392.9,DFN):3
+8 IF '$TEST
WRITE !,*7,"Somebody else is Editing this entry",*7
GOTO EXIT
+9 ;
DO 6^VADPT
DO KVAR^DGBTEND
DO PID^VADPT
+10 IF '+VAEL(1)
WRITE !!,"Eligibility is missing from registration and is required to continue.",*7
GOTO EXIT
+11 ;W !! ZW XX W !
DO GA^DGBTUTL(DFN,"XX(3)",DT,"XX(5)")
+12 IF $DATA(XX(5,1))!(XX(3))
Begin DoDot:1
+13 WRITE !
SET DIR("A")="<D>isplay Income History, or <C>ontinue with current Alt. Income: "
SET DIR(0)="SA^;D:Display;C:Continue"
SET DIR("B")="C"
DO ^DIR
+14 IF Y=U!($GET(DUOUT))
SET EXIT=1
QUIT
+15 if Y="C"
QUIT
+16 WRITE !!,"History of Alt. Incomes:"
SET I=0
+17 FOR
SET I=$ORDER(XX(5,I))
if 'I
QUIT
WRITE !,I,": ",$$FMTE^XLFDT($PIECE(XX(5,I),U,3)),?30,"$",$PIECE(XX(5,I),U,2),?40,$SELECT($PIECE(XX(5,I),U,4)="H":"Hardship",1:"POW"),?50,"Ex: ",$$FMTE^XLFDT($PIECE(XX(5,I),U,5))
+18 if XX(3)
WRITE !,"*",": ",$$FMTE^XLFDT($PIECE(XX(3),U,3)),?30,"$",$PIECE(XX(3),U,2),?40,$SELECT($PIECE(XX(3),U,4)="H":"Hardship",1:"POW"),?50,"Ex: ",$$FMTE^XLFDT($PIECE(XX(3),U,5))
End DoDot:1
WRITE !
if $GET(EXIT)
GOTO EXIT
DATE ;Get the date
+1 KILL DIR
SET DIR("A")="Begin Date"
SET DIR("B")=$$FMTE^XLFDT(DT)
SET DIR(0)="D^"_$$FMADD^XLFDT(DT,-30)_":DT:EA"
+2 DO ^DIR
if (Y=U)!$GET(DTOUT)!$GET(DUOUT)
GOTO EXIT
+3 SET DGBTDTI=Y
SET DGBTDTY=" (Year: "_$$FMTE^XLFDT($EXTRACT(DGBTDTI,1,3)_"0000")_")"
+4 SET XXX(3)=XX(3)
KILL XX
DO PI(DFN,DGBTDTI,.XX)
SET XX(3)=XXX(3)
+5 DO PD
SET TXT=""
RD ;Display - Redisplay Alt. Income on File
+1 IF XX(3)
WRITE !!,*7
if '$LENGTH(TXT)
SET TXT=$$FMTE^XLFDT($PIECE(XX(3),U,3))_": $"_$PIECE(XX(3),U,2)_" Alternate income is on the File"
WRITE TXT
Begin DoDot:1
+2 IF $$FMDIFF^XLFDT(DT,$PIECE(XX(3),U,3))>30
WRITE !!,"No Edit permited for Alt. Income older as 30 days."
SET EXIT=1
QUIT
+3 SET EXIT=0
SET TXT=""
+4 KILL DIR
SET DIR("A")="<D>elete Alt. Income, <E>dit Alt. Income, or <Q>uit "
SET DIR("B")="Quit"
SET DIR(0)="SA^D:Delete;E:Edit;Q:Quit"
DO ^DIR
+5 IF Y="Q"!(Y=U)
SET EXIT=1
QUIT
+6 IF Y="E"
SET X=$$SETINC(DFN,$PIECE(XX(3),U,3),DGBTDTI)
DO GA^DGBTUTL(DFN,"XX(3)",DGBTDTI)
DO PD
SET TXT=$$FMTE^XLFDT($PIECE(XX(3),U,3))_": Alt. Income "_$SELECT($PIECE(XX(3),U,4)="H":"Hardship",1:"POW")_": $"_$PIECE(XX(3),U,2)_" has been Saved "
QUIT
+7 IF Y="D"
SET DA(1)=DFN
SET DA=$PIECE(XX(3),U,3)
SET DIK="^DGBT(392.9,DFN,1,"
DO ^DIK
WRITE !,"Alternate Income Deleted"
SET EXIT=1
End DoDot:1
if EXIT
GOTO EXIT
GOTO RD
+8 IF XX(1)
WRITE !!,"Patient Already Qualified for Low Income Condition",*7
GOTO EXIT
+9 if XX(4)
WRITE !!,"This is the POW Patient",*7
+10 WRITE !
RD1 WRITE !,"Continue Processing Alternate Income"
SET %=1
DO YN^DICN
+1 IF %=2!(%=-1)
GOTO EXIT
+2 IF '%
WRITE !," Answer with 'Yes' or 'No'",*7
GOTO RD1
+3 IF $$SETINC(DFN,,DGBTDTI)
SET DA(1)=DFN
SET DA=DGBTDTI
SET DIK="^DGBT(392.9,DFN,1,"
DO ^DIK
WRITE !,"Alternate Income Deleted"
GOTO EXIT
+4 DO GA^DGBTUTL(DFN,"XX(3)",DGBTDTI)
DO PD
+5 IF XX(3)
WRITE !!,$SELECT($PIECE(XX(3),U,4)="H":"Hardship",1:"POW")_": $",$PIECE(XX(3),U,2)," Begin: ",$$FMTE^XLFDT($PIECE(XX(3),U,3))," Expire: ",$$FMTE^XLFDT($PIECE(XX(3),U,5))," has been Saved "
+6 GOTO EXIT
+7 QUIT
SETINC(DFN,OLDDATE,DGBTDTI) ;Set Alt Income
+1 NEW DIE,DR,Y,FDA,DA
+2 IF $GET(OLDDATE)
SET DA(1)=DFN
SET DA=OLDDATE
SET DIK="^DGBT(392.9,DFN,1,"
DO ^DIK
+3 IF '$DATA(^DGBT(392.9,DFN,0))
SET IENC(1)=DFN
SET FDA(392.9,"+1,",.01)=IENC(1)
DO UPDATE^DIE(,"FDA","IENC")
+4 KILL IENC
SET IENC(2)=DGBTDTI
SET FDA(392.91,"+2,"_DFN_",",.01)=IENC(2)
DO UPDATE^DIE(,"FDA","IENC","DGBTERR")
+5 WRITE !,"Begin of Alt. Income: ",$$FMTE^XLFDT(DGBTDTI)
+6 KILL DIR
SET DIR("A")="Enter the Alternate Income"
SET DIR(0)="392.91,1"
+7 IF $LENGTH($PIECE($GET(XX(3)),U,2))
SET DIR("B")=$PIECE($GET(XX(3)),U,2)
SET DIR(0)="392.91,1"
+8 IF '$TEST
SET DIR(0)="392.91,1A"
SET DIR("A")=DIR("A")_": "
+9 DO ^DIR
+10 ;$S($P($G(XX(3)),U,2):0,1:1)
if Y=U!$GET(DTOUT)
QUIT 1
+11 SET FDA(392.91,DGBTDTI_","_DFN_",",1)=Y
+12 KILL DIR
SET DIR("A")="Enter the Reason for Alternate Income: "
+13 IF XX(4)
SET DIR("B")="P"
SET DIR(0)="SA^P:POW;H:Hardship"
+14 IF '$TEST
SET DIR("B")="H"
SET DIR(0)="SA^H:Hardship"
+15 DO ^DIR
+16 IF Y=U!$GET(DTOUT)
QUIT 1
+17 SET FDA(392.91,DGBTDTI_","_DFN_",",2)=Y
+18 SET FDA(392.91,DGBTDTI_","_DFN_",",3)=$SELECT(Y="H":$EXTRACT(DGBTDTI,1,3)_1231,1:$EXTRACT(DGBTDTI,1,3)+1_$EXTRACT(DGBTDTI,4,7))
+19 DO FILE^DIE(,"FDA")
+20 QUIT 0
PI(DFN,DGBTDTI,XX) ;Return Patient info in XX
+1 ;XX(1)=Already Low Income on Record
+2 ;XX(2)=Hardship on Record <== Discontinued
+3 ;XX(3)=Alt Income is on file 1^$Alt Inc^Date^Reason^Exp Date
+4 ;XX(4)=POW on file
+5 ;XX(5)=Expired Alt Income on file (list) XX(5,I)=Date^income^reason^expiration date
+6 NEW X0,X1,FDA
KILL XX
+7 SET DGBTDEP=$$DEP^VAFMON(DFN,DGBTDTI)
+8 ; Means test threshold
SET DGBTMTTH=$$MTTH^DGBTMTTH(DGBTDEP,DGBTDTI)
+9 ; RX co-pay threshhold
SET DGBTRXTH=+$$THRES^IBARXEU1(DGBTDTI,1,DGBTDEP)
+10 SET X0=+$$LI^DGBTUTL(DFN,DGBTDTI,DGBTDEP,1)
+11 SET XX(1)=$SELECT("1^2"[X0:1,1:0)
+12 ;S XX(2)=$S(X0=3:1,1:0)
+13 DO GA^DGBTUTL(DFN,"XX(3)",DGBTDTI,"XX(5)")
+14 DO SVC^VADPT
+15 SET XX(4)=+$GET(VASV(4))
+16 if XX(4)
QUIT
+17 ;VAEL(1)="15^HOUSEBOUND"
+18 ;VAEL(1,18)="18^PRISONER OF WAR"
+19 IF VAEL(1)["PRISONER OF WAR"
SET XX(4)=1
+20 FOR
SET X0=$ORDER(VAEL(1,X0))
if 'X0
QUIT
IF VAEL(1,X0)["PRISONER OF WAR"
SET XX(4)=1
QUIT
+21 QUIT
PD ;Display patient information
+1 WRITE @IOF
+2 DO PID^VADPT6
DO RESADDR^DGBTUTL1(.DGBTADDR)
WRITE !!?8,"Name: ",VADM(1),?40,"PT ID: ",VA("PID"),?64,"DOB: ",$PIECE(VADM(3),"^",2)
+3 WRITE !!?5,"Address: ",DGBTADDR(1)
if DGBTADDR(2)]""
WRITE !?14,DGBTADDR(2)
+4 ;*39 - updated to use residential address
if DGBTADDR(3)]""
WRITE !?14,DGBTADDR(3)
WRITE !?14,DGBTADDR(4),$SELECT(DGBTADDR(4)]"":", "_$PIECE(DGBTADDR(5),"^",2)_" "_$PIECE(DGBTADDR(6),"^",2),1:"UNSPECIFIED")
+5 ; if move in current info for elig, sc%
+6 SET DGBTELG=VAEL(1)
SET DGBTCSC=VAEL(3)
+7 IF +DGBTELG=3
IF '$EXTRACT(DGBTCSC)=1
SET DGBTCSC=1
+8 WRITE !!," Eligibility: ",$PIECE(DGBTELG,"^",2)
if DGBTCSC
WRITE ?45,"SC%: ",$PIECE(DGBTCSC,"^",2)
WRITE ?65,"POW:",$SELECT(XX(4):"YES",1:"NO")
WRITE !
+9 IF $ORDER(VAEL(1,0))'=""
WRITE !," Other Elig.: "
FOR I=0:0
SET I=$ORDER(VAEL(1,I))
if 'I
QUIT
WRITE ?14,$PIECE(VAEL(1,I),"^",2)," "
+10 ; service connected status/information
+11 IF DGBTCSC&($PIECE(DGBTCSC,"^",2)'>29)
WRITE !!,"Disabilities:"
SET I3=""
+12 NEW DGQUIT,I
+13 FOR I=0:0
SET I=$ORDER(^DPT(DFN,.372,I))
if 'I!($GET(DGQUIT)=1)
QUIT
Begin DoDot:1
+14 SET I1=^(I,0)
SET I2=$SELECT($DATA(^DIC(31,+I1,0)):$PIECE(^(0),"^",1)_" ("_+$PIECE(I1,"^",2)_"%-"_$SELECT($PIECE(I1,"^",3):"SC",1:"NSC")_")",1:"")
SET I3=I1
+15 IF $Y>(IOSL-3)
DO PAUSE
IF $GET(DGQUIT)=0
WRITE @IOF
+16 IF $GET(DGQUIT)=1
QUIT
+17 WRITE ?16
WRITE I2,!
End DoDot:1
+18 ;;;
+19 if XX(3)
Begin DoDot:1
+20 NEW X,X2,X3
+21 ; returns income & source.
SET X=$PIECE(XX(3),U,2)
SET DGBTIFL=$EXTRACT($PIECE(XX(3),U,4))
+22 IF X?1N.E!(X<0)
Begin DoDot:2
End DoDot:2
+23 IF X<0
SET X=0
+24 SET X2="0$"
SET X3=8
DO COMMA^%DTC
+25 SET DGBTINC=X_U_$GET(DGBTIFL)
End DoDot:1
+26 SET DGBTDT=DGBTDTI
SET DGBTINCA=XX(3)
+27 IF $$DAYSTEST^DGBT1(DFN,.DAYFLG,.RXDAYS,.RXCPST,.LOWINC,.DGNOTEST)
+28 ; Inserted PATCH 24
+29 IF $$MTCHK^DGBTUTL1(DFN,DGBTDT)>0
Begin DoDot:1
+30 SET (DAYFLG,DGBTDYFL)=1
End DoDot:1
+31 SET X=$$LST^DGMTCOU1(DFN,DT,3)
SET DGBTMTS=$PIECE(X,U,4)_U_$PIECE(X,U,3)
+32 ; PAVEL
if XX(3)
SET RXCPST=0
SET DGBTMTS=U
SET DAYFLG=1
+33 ;I DAYFLG,$G(RXCPST),$G(RXCP)'=1 S DGBTINC="^",DGBTIFL=""
+34 IF DAYFLG
IF $GET(RXCPST)
SET DGBTIFL="C"
if DGBTMTS]""
SET DGBTMTS=U
if $GET(RXCP)'=1
SET DGBTINC="^"
+35 IF 'DAYFLG
SET DGBTINC="^"
SET DGBTIFL="^"
SET DGBTMTS="EX^"
+36 WRITE !!?2,"Income: ",$PIECE($GET(DGBTINC),U),$GET(DGBTDTY),?35,"Source of Income: "
+37 WRITE $SELECT($GET(DGBTIFL)="M":"MEANS TEST",$GET(DGBTIFL)="C":"COPAY TEST",$GET(DGBTIFL)="P":"Alt. Income POW",$GET(DGBTIFL)="H":"Alt. Income Hardship",1:"")
+38 IF XX(3)
WRITE !,?40," (Expire: ",$$FMTE^XLFDT($PIECE(XX(3),U,5)),")"
+39 WRITE !?2,"No. of Dependents: ",+DGBTDEP
+40 IF DGBTMTS]""
if $PIECE(DGBTMTS,"^")'="N"
WRITE ?35,"MT Status: ",$SELECT($PIECE(DGBTMTS,"^")="EX":"EXPIRED",$PIECE(DGBTMTS,"^")="R":"REQUIRED",$PIECE(DGBTMTS,"^")="P":$PIECE($PIECE(DGBTMTS,"^",2)," "),DGBTMTS=U!($GET(RXCPST)):" NOT APPLICABLE",1:$PIECE(DGBTMTS,"^",2))
+41 ;
+42 QUIT
PAUSE ;added with DGBT*1*11
+1 IF $EXTRACT(IOST,1,2)["C-"
NEW DIR
SET DIR(0)="E"
DO ^DIR
SET DGQUIT='Y
+2 QUIT
EXIT ;Exit patient
+1 IF $GET(DFN)
LOCK -^DGBT(392.9,DFN)
+2 WRITE !!,"EXITING Patient"
DO KILL
GOTO ALT
+3 QUIT
EXITE ; Exit Menu
+1 IF $GET(DFN)
LOCK -^DGBT(392.9,DFN)
+2 WRITE !!,"EXITING Alternate Income Menu"
DO KILL
+3 QUIT
KILL ;Kill Local variable.. Dont use NEW, because of return to Patient Prompt
+1 KILL DGBTTOUT,DGBTAI,DGBTAIE,DGBTR,DGBTHAR,DGBTELG,VAEL,DGBTCSC,VAPA,VASV,DGBTDEP,DGBTIFL,DGBTINC,IENC,DGBTDTI,DGBTERR,DGBTMTS,DGBTDTY,TXT
+2 KILL DGBTINCA,DAYFLG,RXDAYS,RXCPST,LOWINC,DGNOTEST,RXCP,DDD
+3 ;*39 kill dgbtaddr
KILL X,Y,I,I1,I2,I3,X2,DFN,DIC,Y,EXP,DA,DR,DIE,FDA,XX,XXX,DIR,EXIT,%DT,DGBTADDR
