FBCHREQ ;AISC/DMK - USED FOR FEE NOTIFICATION/REQUEST ;1/22/15 12:14
;;3.5;FEE BASIS;**154**;JAN 30, 1995;Build 12
;;Per VA Directive 6402, this routine should not be modified.
ADD ;Entry point for entering a notification/request
D FEE^DGREG G END:'$D(DFN)
W ! S DIC="^FBAA(162.2,",DIC(0)="AQLMZ",DLAYGO=162.2,DIC("S")="I $P(^(0),U,4)=DFN" D ^DIC K DIC("S")
G END:X=""!(X="^"),ADD:Y<0 S FBDA=+Y,FBN=$P(Y,"^",3)
W *7,?55,$$DATX^FBAAUTL($P(Y,"^",2))
I FBN="",$P(Y(0),U,15)=3 W !,*7,"This notification has a status of complete. Cannot edit.",! K FBN D END G ADD
I FBN="" S FBCHVEN=$P(^FBAA(162.2,FBDA,0),"^",2)
D VENDOR^FBCHREQ1:FBN I '$D(FBCHVEN) S DA=FBDA G EN^FBCHREQ1
W ! S DIE="^FBAA(162.2,",DA=FBDA,DR="[FBCH ENTER REQUEST]" D ^DIE
G END:'$D(DA) I FBN G:$D(Y)'=0!($G(FBOUT)) EN^FBCHREQ1
I FBLG>0 W !,*7,"Admission overlaps another request for this patient.",! G EN^FBCHREQ1
D
. N FBTXT,FBX
. S FBTXT=$S(FBN:"Enter",1:"Edit")_" CH notification."
. S FBX=$$ADDUA^FBUTL9(162.2,FBDA_",",FBTXT)
. I 'FBX W !,"Error adding record in User Audit. Please contact IRM."
I FBUP W !!,?15,"REPORT OF CONTACT INFORMATION",! D ^FBCHROC
K DIC,DIE,DLAYGO,DA,DR,DFN,FBAUT,FBBEGDT,FBFLAG,FBLG,FBOUT,FBPROG,FBVT,Z,FBN,FBSW,VAL,FBX,HY,FBUP,FBAAPN,FBDA,FBDEL,FBPER,J,VA,X,X1,X2,D,FBCHTEL,FBCHVEN,FBDATE,FBVD,FBZZ,Y,ZZZ,FBDOA
Q
;
LENT ;Entry point for enter/edit legal entitlement
S DIC("S")="I $P(^(0),U,15)'=3" D ASKV G END:X="^"!(X="") S FBLENT=""
LENT1 S DFN=+$P(^FBAA(162.2,DA,0),"^",4),X=$G(^DPT(DFN,.361))
I $P(X,"^")="" W !!,?10,"ELIGIBILITY HAS NOT BEEN DETERMINED NOR PENDING",!,?10,"CANNOT ENTER ENTITLEMENT." G END
ELIG I $D(^DPT(DFN,.32)),$P(^(.32),"^",4)=2 W !,?4,"VETERAN HAS A DISHONORABLE DISCHARGE, " S X=$S($D(^(.321)):$P(^(.321),"^",1),1:"") W $S(X="Y":"ONLY ELIGIBLE FOR AGENT ORANGE EXAM.",1:"NOT ELIGIBLE FOR BENEFITS.")
I "N"[$E(X) S DIR(0)="Y",DIR("A")="Do you want to continue",DIR("B")="NO" D ^DIR K DIR G END:$D(DIRUT) I 'Y D INELI G END
W !! S DIE=DIC,DR="8;S FBLENT=X;S:FBLENT']"""" Y=0;S:FBLENT=""Y"" Y=9;11///^S X=""N"";12////^S X=DT;14;S:X'=4 Y=9;15;9////^S X=DT;10////^S X=DUZ;100////^S X=$S(FBLENT=""N"":3,1:2)" D ^DIE
D
. N FBX
. S FBX=$$ADDUA^FBUTL9(162.2,DA_",","Legal entitlement.")
. I 'FBX W !,"Error adding record in User Audit. Please contact IRM."
G END:FBLENT="N"!(FBLENT="")
;
ASK S DIR(0)="Y",DIR("A")="Do you want to determine Medical Entitlement now",DIR("B")="YES" D ^DIR K DIR G END:$D(DIRUT)!'Y,MENT1:Y
Q
;
MENT ;Entry point for enter/edit medical entitlement
S DIC("S")="S FZ=^(0) I $P(FZ,U,9)=""Y""&($P(FZ,U,17)="""")&($S($P(FZ,U,12)="""":1,$P(FZ,U,12)=""Y"":1,1:0)) K FZ"
D ASKV G END:X="^"!(X="")
MENT1 S FBMENT="" W !! S DIE=DIC,DR="11;S FBMENT=X;S:FBMENT']"""" Y=0;12////^S X=DT;S:FBMENT=""Y"" Y=13;14;S:X'=4 Y=13;15;13////^S X=DUZ;100////^S X=3" D ^DIE
D
. N FBX
. S FBX=$$ADDUA^FBUTL9(162.2,DA_",","Medical entitlement.")
. I 'FBX W !,"Error adding record in User Audit. Please contact IRM."
;
SETUP I FBMENT="Y" S DIR(0)="Y",DIR("A")="Do you want to setup a 7078 now",DIR("B")="NO" D ^DIR K DIR G END:$D(DIRUT)!'Y,EN^FBCH78:Y
END K DA,FBAUT,FBBEGDT,FBDA,FBOUT,FBFLAG,FBLG,FBPROG,FBVT,Z,FBADA,FBV,FBVT,FBLENT,FBDFN,FBNAME,FBSSN,FBMENT,FBX,DIC,DIE,DR,DLAYGO,D,DFN,VAL,X,Y,FBSUSP,FBUP,FBPHY,FBCHTEL,FBAAPN,FBAADT,DF,FBAUT,FBBEGDT,FBCHVEN,FBDEL,FBFLAG
K FB,FB1,FBOUT,FBPER,FBPROG,FBSW,FBVD,VAL,D0,S,A,DIRUT,DUOUT,DTOUT,FBDOA,FBADDT
Q
;
ASKV ;Look-Up call by veteran for file 162.2
W ! S DIC="^FBAA(162.2,",DIC(0)="AEQMZ",DIC("A")="Select Patient: ",D="D" D IX^DIC K DIC("A"),DIC("S"),D Q:X="^"!(X="") G ASKV:Y<0 S (DA,FBDA)=+Y
S FBDFN=+$P(Y(0),"^",4) I $D(^DPT(FBDFN,0)) S FBNAME=$P(^(0),"^"),FBSSN=$TR($$SSN^FBAAUTL(FBDFN),"-","") Q
Q
;
CHEK ;Check for another request for same pt. not completed
S FBVT=DFN I $D(^FB7078("AC","I",FBVT)) S FB7078=$O(^FB7078("AC","I",FBVT,0)),FB7078=$S($D(^FB7078(FB7078,0)):$P(^(0),"^",1),1:"") G KILL
Q
;
KILL W !!,"There is an incomplete 7078 for this patient.",!,"The reference number is "_FB7078 S DIK="^FBAA(162.2," D ^DIK S Y=0 W !!,?19,"< NEW REQUEST DELETED >" K FB7078,FBVT,DFN,DIK,DA,D,FBN Q
;
INELI S DIR(0)="162.2,14" D ^DIR G END:$D(DUOUT)!$D(DTOUT)
S FBSUSP=+Y G END:X=""!(X="^"),INELI:Y<0
S DIE=DIC,DR="12////^S X=DT;7////^S X=DUZ;8////^S X=""N"";14////^S X=FBSUSP;S:X'=4 Y=9;15;9////^S X=DT;10////^S X=DUZ;11////^S X=""N"";100////^S X=3" D ^DIE Q
;
OUTP ;Entry to inquire about a notification/request
D ASKV G END:X="^"!(X="") W !! S DR="0:99" D EN^DIQ
G OUTP
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBCHREQ 4576 printed Dec 13, 2024@01:57:52 Page 2
FBCHREQ ;AISC/DMK - USED FOR FEE NOTIFICATION/REQUEST ;1/22/15 12:14
+1 ;;3.5;FEE BASIS;**154**;JAN 30, 1995;Build 12
+2 ;;Per VA Directive 6402, this routine should not be modified.
ADD ;Entry point for entering a notification/request
+1 DO FEE^DGREG
if '$DATA(DFN)
GOTO END
+2 WRITE !
SET DIC="^FBAA(162.2,"
SET DIC(0)="AQLMZ"
SET DLAYGO=162.2
SET DIC("S")="I $P(^(0),U,4)=DFN"
DO ^DIC
KILL DIC("S")
+3 if X=""!(X="^")
GOTO END
if Y<0
GOTO ADD
SET FBDA=+Y
SET FBN=$PIECE(Y,"^",3)
+4 WRITE *7,?55,$$DATX^FBAAUTL($PIECE(Y,"^",2))
+5 IF FBN=""
IF $PIECE(Y(0),U,15)=3
WRITE !,*7,"This notification has a status of complete. Cannot edit.",!
KILL FBN
DO END
GOTO ADD
+6 IF FBN=""
SET FBCHVEN=$PIECE(^FBAA(162.2,FBDA,0),"^",2)
+7 if FBN
DO VENDOR^FBCHREQ1
IF '$DATA(FBCHVEN)
SET DA=FBDA
GOTO EN^FBCHREQ1
+8 WRITE !
SET DIE="^FBAA(162.2,"
SET DA=FBDA
SET DR="[FBCH ENTER REQUEST]"
DO ^DIE
+9 if '$DATA(DA)
GOTO END
IF FBN
if $DATA(Y)'=0!($GET(FBOUT))
GOTO EN^FBCHREQ1
+10 IF FBLG>0
WRITE !,*7,"Admission overlaps another request for this patient.",!
GOTO EN^FBCHREQ1
+11 Begin DoDot:1
+12 NEW FBTXT,FBX
+13 SET FBTXT=$SELECT(FBN:"Enter",1:"Edit")_" CH notification."
+14 SET FBX=$$ADDUA^FBUTL9(162.2,FBDA_",",FBTXT)
+15 IF 'FBX
WRITE !,"Error adding record in User Audit. Please contact IRM."
End DoDot:1
+16 IF FBUP
WRITE !!,?15,"REPORT OF CONTACT INFORMATION",!
DO ^FBCHROC
+17 KILL DIC,DIE,DLAYGO,DA,DR,DFN,FBAUT,FBBEGDT,FBFLAG,FBLG,FBOUT,FBPROG,FBVT,Z,FBN,FBSW,VAL,FBX,HY,FBUP,FBAAPN,FBDA,FBDEL,FBPER,J,VA,X,X1,X2,D,FBCHTEL,FBCHVEN,FBDATE,FBVD,FBZZ,Y,ZZZ,FBDOA
+18 QUIT
+19 ;
LENT ;Entry point for enter/edit legal entitlement
+1 SET DIC("S")="I $P(^(0),U,15)'=3"
DO ASKV
if X="^"!(X="")
GOTO END
SET FBLENT=""
LENT1 SET DFN=+$PIECE(^FBAA(162.2,DA,0),"^",4)
SET X=$GET(^DPT(DFN,.361))
+1 IF $PIECE(X,"^")=""
WRITE !!,?10,"ELIGIBILITY HAS NOT BEEN DETERMINED NOR PENDING",!,?10,"CANNOT ENTER ENTITLEMENT."
GOTO END
ELIG IF $DATA(^DPT(DFN,.32))
IF $PIECE(^(.32),"^",4)=2
WRITE !,?4,"VETERAN HAS A DISHONORABLE DISCHARGE, "
SET X=$SELECT($DATA(^(.321)):$PIECE(^(.321),"^",1),1:"")
WRITE $SELECT(X="Y":"ONLY ELIGIBLE FOR AGENT ORANGE EXAM.",1:"NOT ELIGIBLE FOR BENEFITS.")
+1 IF "N"[$EXTRACT(X)
SET DIR(0)="Y"
SET DIR("A")="Do you want to continue"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END
IF 'Y
DO INELI
GOTO END
+2 WRITE !!
SET DIE=DIC
SET DR="8;S FBLENT=X;S:FBLENT']"""" Y=0;S:FBLENT=""Y"" Y=9;11///^S X=""N"";12////^S X=DT;14;S:X'=4 Y=9;15;9////^S X=DT;10////^S X=DUZ;100////^S X=$S(FBLENT=""N"":3,1:2)"
DO ^DIE
+3 Begin DoDot:1
+4 NEW FBX
+5 SET FBX=$$ADDUA^FBUTL9(162.2,DA_",","Legal entitlement.")
+6 IF 'FBX
WRITE !,"Error adding record in User Audit. Please contact IRM."
End DoDot:1
+7 if FBLENT="N"!(FBLENT="")
GOTO END
+8 ;
ASK SET DIR(0)="Y"
SET DIR("A")="Do you want to determine Medical Entitlement now"
SET DIR("B")="YES"
DO ^DIR
KILL DIR
if $DATA(DIRUT)!'Y
GOTO END
if Y
GOTO MENT1
+1 QUIT
+2 ;
MENT ;Entry point for enter/edit medical entitlement
+1 SET DIC("S")="S FZ=^(0) I $P(FZ,U,9)=""Y""&($P(FZ,U,17)="""")&($S($P(FZ,U,12)="""":1,$P(FZ,U,12)=""Y"":1,1:0)) K FZ"
+2 DO ASKV
if X="^"!(X="")
GOTO END
MENT1 SET FBMENT=""
WRITE !!
SET DIE=DIC
SET DR="11;S FBMENT=X;S:FBMENT']"""" Y=0;12////^S X=DT;S:FBMENT=""Y"" Y=13;14;S:X'=4 Y=13;15;13////^S X=DUZ;100////^S X=3"
DO ^DIE
+1 Begin DoDot:1
+2 NEW FBX
+3 SET FBX=$$ADDUA^FBUTL9(162.2,DA_",","Medical entitlement.")
+4 IF 'FBX
WRITE !,"Error adding record in User Audit. Please contact IRM."
End DoDot:1
+5 ;
SETUP IF FBMENT="Y"
SET DIR(0)="Y"
SET DIR("A")="Do you want to setup a 7078 now"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
if $DATA(DIRUT)!'Y
GOTO END
if Y
GOTO EN^FBCH78
END KILL DA,FBAUT,FBBEGDT,FBDA,FBOUT,FBFLAG,FBLG,FBPROG,FBVT,Z,FBADA,FBV,FBVT,FBLENT,FBDFN,FBNAME,FBSSN,FBMENT,FBX,DIC,DIE,DR,DLAYGO,D,DFN,VAL,X,Y,FBSUSP,FBUP,FBPHY,FBCHTEL,FBAAPN,FBAADT,DF,FBAUT,FBBEGDT,FBCHVEN,FBDEL,FBFLAG
+1 KILL FB,FB1,FBOUT,FBPER,FBPROG,FBSW,FBVD,VAL,D0,S,A,DIRUT,DUOUT,DTOUT,FBDOA,FBADDT
+2 QUIT
+3 ;
ASKV ;Look-Up call by veteran for file 162.2
+1 WRITE !
SET DIC="^FBAA(162.2,"
SET DIC(0)="AEQMZ"
SET DIC("A")="Select Patient: "
SET D="D"
DO IX^DIC
KILL DIC("A"),DIC("S"),D
if X="^"!(X="")
QUIT
if Y<0
GOTO ASKV
SET (DA,FBDA)=+Y
+2 SET FBDFN=+$PIECE(Y(0),"^",4)
IF $DATA(^DPT(FBDFN,0))
SET FBNAME=$PIECE(^(0),"^")
SET FBSSN=$TRANSLATE($$SSN^FBAAUTL(FBDFN),"-","")
QUIT
+3 QUIT
+4 ;
CHEK ;Check for another request for same pt. not completed
+1 SET FBVT=DFN
IF $DATA(^FB7078("AC","I",FBVT))
SET FB7078=$ORDER(^FB7078("AC","I",FBVT,0))
SET FB7078=$SELECT($DATA(^FB7078(FB7078,0)):$PIECE(^(0),"^",1),1:"")
GOTO KILL
+2 QUIT
+3 ;
KILL WRITE !!,"There is an incomplete 7078 for this patient.",!,"The reference number is "_FB7078
SET DIK="^FBAA(162.2,"
DO ^DIK
SET Y=0
WRITE !!,?19,"< NEW REQUEST DELETED >"
KILL FB7078,FBVT,DFN,DIK,DA,D,FBN
QUIT
+1 ;
INELI SET DIR(0)="162.2,14"
DO ^DIR
if $DATA(DUOUT)!$DATA(DTOUT)
GOTO END
+1 SET FBSUSP=+Y
if X=""!(X="^")
GOTO END
if Y<0
GOTO INELI
+2 SET DIE=DIC
SET DR="12////^S X=DT;7////^S X=DUZ;8////^S X=""N"";14////^S X=FBSUSP;S:X'=4 Y=9;15;9////^S X=DT;10////^S X=DUZ;11////^S X=""N"";100////^S X=3"
DO ^DIE
QUIT
+3 ;
OUTP ;Entry to inquire about a notification/request
+1 DO ASKV
if X="^"!(X="")
GOTO END
WRITE !!
SET DR="0:99"
DO EN^DIQ
+2 GOTO OUTP
