DGBTALTI.m

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 ---DGBTALTI   8213     printed  Mar 13, 2025@20:45:03                                                                                                                                                                                                    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