- 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 Jan 18, 2025@02:59:05 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