- FBAAUTL1 ;AISC/GRR - Fee Basis Utility Routine ;9/12/2012
- ;;3.5;FEE BASIS;**3,12,13,108,132**;JAN 30, 1995;Build 17
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- PLUSOB ;ENTRY POINT TO INCREASE OBLIGATION ADJUSTMENT
- S FBAAMT="-"_FBAARA
- D ADD Q
- ;D NOW^%DTC S X=FBAAOB_"^"_%_"^^"_FBAAMT_"^"_FBAAB_"^"_FBCOMM,PRCS("TYPE")="FB" D EN2^PRCS58 I +Y=0 W !!,*7,Y,! S FBERR=1 Q
- Q
- VALCK ;DETERMINE VALIDITY OF RESPONSE
- S VAL=0 I $E(X)="?"!("YyNn"'[$E(X,1)) D HELPYN Q
- S VAL=1
- Q
- HELPYN ;DISPLAY HELP TEXT FOR YES OR NO
- W !!,"Please enter 'Yes' or 'No'."
- Q
- GETVET D DT^DICRW S DFN="",U="^" W !! S DIC="^FBAAA(",DIC(0)="AEMQZ",DIC("A")="Select Patient: " D ^DIC K DIC("A"),DIC("S") Q:Y<0 S (D0,DFN)=+Y
- Q
- GETAUTH S CNT=0,FTP="" N FB,FBFDT
- I '$D(^FBAAA(DFN,1)) W !!,"PATIENT HAS NO AUTHORIZATIONS " Q
- S FBPROG=$S($D(FBPROG):FBPROG,1:"I 1")
- S FBFDT=9999999 F S FBFDT=$O(^FBAAA(DFN,1,"B",FBFDT),-1) Q:'FBFDT D
- . S I=0 F S I=$O(^FBAAA(DFN,1,"B",FBFDT,I)) Q:'I I $D(^FBAAA(DFN,1,I,0)) X FBPROG I S CNT=CNT+1,CNT(CNT)=I
- S PI="" D HOME^%ZIS D ^FBAADEM
- I CNT<1 W !!,"Veteran does NOT have an Authorization for the Fee Program being used !!" G Q
- RD I CNT=1 S DIR(0)="Y",DIR("A")="Is this the correct Authorization period (Y/N)",DIR("B")="Yes" D ^DIR K DIR G:Y=0!($D(DIRUT)) NOAUTH S X=1 G 2
- CHOOS W !! S DIR(0)="N^1:"_CNT D ^DIR K DIR S X=+Y Q:$D(DUOUT) G H^XUS:$D(DTOUT)
- 2 S (FTP,X)=CNT(X),FB=$G(^FBAAA(DFN,1,X,0)),FBAABDT=$P(FB,"^"),FBAAEDT=$P(FB,"^",2),FBTYPE=$P(FB,"^",3),TA=$P(FB,"^",11),FBTT=$P(FB,"^",13),FBPOV=$P(FB,"^",7),FBPT=$P(FB,"^",18),FBPSA=$P(FB,"^",5),FBVEN=$P(FB,"^",4),FB7078=""
- I $P(FB,"^",9)[";FB7078(" S FB7078=+$P(FB,"^",9)
- I $P(FB,"^",9)[";FB583(" S FB583=+$P(FB,"^",9)
- S FBDMRA=$G(^FBAAA(DFN,1,X,"ADEL")) I FBDMRA']"" K FBDMRA
- S FBASSOC=X
- I FB7078]"" S FBVEN=+$P($G(^FB7078(+FB7078,0)),U,2)
- S FBCNTRA=$P(FB,"^",22)
- Q Q
- GETAUTHK ; kill new authorization variables output from GETAUTH
- K FBCNTRA
- Q
- DAYS ;CALCULATES THE NUMBER OF DAYS IN MONTH
- S X1=X,X=+$E(X,4,5),X=$S("^1^3^5^7^8^10^12^"[("^"_X_"^"):31,X=2:28,1:30)
- I X=28 D
- . N YEAR
- . S YEAR=$E(X1,1,3)+1700
- . I $S(YEAR#400=0:1,YEAR#4=0&'(YEAR#100=0):1,1:0) S X=29
- Q
- DATCK2 I $D(FBAABDT),$D(FBAAEDT),Y<FBAABDT!(Y\1>FBAAEDT) W !!,*7,"Date ",$S(Y<FBAABDT:"prior to ",1:"later than "),"Authorization period",! K X Q
- I $D(FBTRT),$D(FBLTD),(9999999.999999-Y)'<FBLTD W !,*7,"There is already an existing admission for this authorization!",! K X
- Q
- DATCK3 I $D(FBLTTYP),FBLTTYP]"",FBLTTYP<4,(X-3)'=FBLTTYP W !!,*7,"That transfer type NOT consistent with last transfer type!",! K X
- I $D(FBLTT),FBLTT="A",X>3 W !!,*7,"A 'Transfer From' type transaction can only follow a 'Transfer To' type!",! K X
- Q
- WRONGT ;WRONG TYPE OF AUTHORIZATION SELECTED
- W !!,"Authorization type selected inconsistent with option being used" Q
- GETVEN ;LOOKUP VENDOR
- W ! S DIC=161.2,DIC(0)="AEQM",IFN="" D ^DIC Q:Y<0 S IFN=+Y Q
- HANG ;IF $E(IOST,1,2)["C-" ASK TO CONTINUE
- S DIR(0)="E" D ^DIR K DIR S:'Y FBAAOUT=1 Q
- CKOB D STATION^FBAAUTL I $D(FB("ERROR")) K FB("ERROR"),X Q
- S PRC("SITE")=$S($D(PRC("SITE")):PRC("SITE"),1:FBSN) K FBSN,FBAASN
- I '$D(^PRC(442,"B",PRC("SITE")_"-"_X)) W !,"This Obligation number does not exist in the IFCAP file!",! K PRC,X
- Q
- CK1358 ;CHECK TO SEE IF 1358 AVAILABLE
- ;FBAAOB=FULL OBLIGATION NUMBER (STA-CXXXXX)
- ;RETURNS Y=1 IF OK
- S PRCS("X")=FBAAOB,PRCS("TYPE")="FB" D EN3^PRCS58 I Y=-1 W !!,*7,"1358 not available for posting!",! S FBERR=1 Q
- Q
- NOAUTH S (FTP,X)="" Q
- LOCK W !!,*7,"Queueing has been initiated by another user and is now in progress!",!! Q
- ;
- XSET ;SET X-REF IN FILE 161.27 FOR LOOK-UP BY SHORT DESCRIPTION
- S ZZ=^FBAA(161.27,DA,2) D TRANS S ^FBAA(161.27,"C",$E(ZZ,1,30),DA)=""
- K ZZ Q
- XKILL ;
- S ZZ=^FBAA(161.27,DA,2) D TRANS K ^FBAA(161.27,"C",$E(ZZ,1,30),DA)
- K ZZ Q
- ;
- TRANS ;
- S ZZ=$TR(ZZ,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
- Q
- ;
- VER() ;no parameters passed
- ;returns 1 if site is running version 4 of IFCAP
- ;S X=$G(^DIC(9.4,+$O(^DIC(9.4,"C","PRC",0)),"VERSION"))
- N X
- S X=$$VERSION^XPDUTL("PRC")
- Q $S(+X=4:1,1:0)
- ;
- ADD ;call to add money back into 1358 when version of IFCAP>3.6
- ;uses interface ID look-up to get internal entry number
- ;interface ID = IEN of batch from 161.7
- ;find ien to 424 by $O(^PRC(424,"E",FBN,0))
- ;call NOT used for civil hospital/cnh
- S PRCS("X")=FBAAOB,PRCS("TYPE")="FB" D EN3^PRCS58 I Y=-1 W !!,*7,"1358 not available for posting!",! S FBERR=1 Q
- N FBADDX S FBADDX=$O(^PRC(424,"E",+$G(FBN),0)) I 'FBADDX S FBERR=1 Q
- D NOW^%DTC
- S PRCSX=FBADDX_"^"_%_"^"_FBAAMT_"^"_FBCOMM_"^"_1
- D ^PRCS58CC I Y'=1 W !!,*7,$P(Y,U,2),! S FBERR=1
- Q
- ;
- ASKVET(FBSCR) ; Prompt for patient
- ; input FBSCR - (optional) screen logic for DIC lookup
- ; e.g. I $D(^FBAAC("AH",12,+Y))
- ; returns IEN of patient in file 161 or 0 if none selected
- N DIC,FBRET,Y
- S FBRET=0
- W !!
- S DIC="^FBAAA("
- S DIC(0)="AQEM"
- S:$G(FBSCR)'="" DIC("S")=FBSCR
- D ^DIC
- I Y'<0 S FBRET=+Y
- Q FBRET
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAUTL1 5069 printed Jan 18, 2025@02:57:59 Page 2
- FBAAUTL1 ;AISC/GRR - Fee Basis Utility Routine ;9/12/2012
- +1 ;;3.5;FEE BASIS;**3,12,13,108,132**;JAN 30, 1995;Build 17
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- PLUSOB ;ENTRY POINT TO INCREASE OBLIGATION ADJUSTMENT
- +1 SET FBAAMT="-"_FBAARA
- +2 DO ADD
- QUIT
- +3 ;D NOW^%DTC S X=FBAAOB_"^"_%_"^^"_FBAAMT_"^"_FBAAB_"^"_FBCOMM,PRCS("TYPE")="FB" D EN2^PRCS58 I +Y=0 W !!,*7,Y,! S FBERR=1 Q
- +4 QUIT
- VALCK ;DETERMINE VALIDITY OF RESPONSE
- +1 SET VAL=0
- IF $EXTRACT(X)="?"!("YyNn"'[$EXTRACT(X,1))
- DO HELPYN
- QUIT
- +2 SET VAL=1
- +3 QUIT
- HELPYN ;DISPLAY HELP TEXT FOR YES OR NO
- +1 WRITE !!,"Please enter 'Yes' or 'No'."
- +2 QUIT
- GETVET DO DT^DICRW
- SET DFN=""
- SET U="^"
- WRITE !!
- SET DIC="^FBAAA("
- SET DIC(0)="AEMQZ"
- SET DIC("A")="Select Patient: "
- DO ^DIC
- KILL DIC("A"),DIC("S")
- if Y<0
- QUIT
- SET (D0,DFN)=+Y
- +1 QUIT
- GETAUTH SET CNT=0
- SET FTP=""
- NEW FB,FBFDT
- +1 IF '$DATA(^FBAAA(DFN,1))
- WRITE !!,"PATIENT HAS NO AUTHORIZATIONS "
- QUIT
- +2 SET FBPROG=$SELECT($DATA(FBPROG):FBPROG,1:"I 1")
- +3 SET FBFDT=9999999
- FOR
- SET FBFDT=$ORDER(^FBAAA(DFN,1,"B",FBFDT),-1)
- if 'FBFDT
- QUIT
- Begin DoDot:1
- +4 SET I=0
- FOR
- SET I=$ORDER(^FBAAA(DFN,1,"B",FBFDT,I))
- if 'I
- QUIT
- IF $DATA(^FBAAA(DFN,1,I,0))
- XECUTE FBPROG
- IF $TEST
- SET CNT=CNT+1
- SET CNT(CNT)=I
- End DoDot:1
- +5 SET PI=""
- DO HOME^%ZIS
- DO ^FBAADEM
- +6 IF CNT<1
- WRITE !!,"Veteran does NOT have an Authorization for the Fee Program being used !!"
- GOTO Q
- RD IF CNT=1
- SET DIR(0)="Y"
- SET DIR("A")="Is this the correct Authorization period (Y/N)"
- SET DIR("B")="Yes"
- DO ^DIR
- KILL DIR
- if Y=0!($DATA(DIRUT))
- GOTO NOAUTH
- SET X=1
- GOTO 2
- CHOOS WRITE !!
- SET DIR(0)="N^1:"_CNT
- DO ^DIR
- KILL DIR
- SET X=+Y
- if $DATA(DUOUT)
- QUIT
- if $DATA(DTOUT)
- GOTO H^XUS
- 2 SET (FTP,X)=CNT(X)
- SET FB=$GET(^FBAAA(DFN,1,X,0))
- SET FBAABDT=$PIECE(FB,"^")
- SET FBAAEDT=$PIECE(FB,"^",2)
- SET FBTYPE=$PIECE(FB,"^",3)
- SET TA=$PIECE(FB,"^",11)
- SET FBTT=$PIECE(FB,"^",13)
- SET FBPOV=$PIECE(FB,"^",7)
- SET FBPT=$PIECE(FB,"^",18)
- SET FBPSA=$PIECE(FB,"^",5)
- SET FBVEN=$PIECE(FB,"^",4)
- SET FB7078=""
- +1 IF $PIECE(FB,"^",9)[";FB7078("
- SET FB7078=+$PIECE(FB,"^",9)
- +2 IF $PIECE(FB,"^",9)[";FB583("
- SET FB583=+$PIECE(FB,"^",9)
- +3 SET FBDMRA=$GET(^FBAAA(DFN,1,X,"ADEL"))
- IF FBDMRA']""
- KILL FBDMRA
- +4 SET FBASSOC=X
- +5 IF FB7078]""
- SET FBVEN=+$PIECE($GET(^FB7078(+FB7078,0)),U,2)
- +6 SET FBCNTRA=$PIECE(FB,"^",22)
- Q QUIT
- GETAUTHK ; kill new authorization variables output from GETAUTH
- +1 KILL FBCNTRA
- +2 QUIT
- DAYS ;CALCULATES THE NUMBER OF DAYS IN MONTH
- +1 SET X1=X
- SET X=+$EXTRACT(X,4,5)
- SET X=$SELECT("^1^3^5^7^8^10^12^"[("^"_X_"^"):31,X=2:28,1:30)
- +2 IF X=28
- Begin DoDot:1
- +3 NEW YEAR
- +4 SET YEAR=$EXTRACT(X1,1,3)+1700
- +5 IF $SELECT(YEAR#400=0:1,YEAR#4=0&'(YEAR#100=0):1,1:0)
- SET X=29
- End DoDot:1
- +6 QUIT
- DATCK2 IF $DATA(FBAABDT)
- IF $DATA(FBAAEDT)
- IF Y<FBAABDT!(Y\1>FBAAEDT)
- WRITE !!,*7,"Date ",$SELECT(Y<FBAABDT:"prior to ",1:"later than "),"Authorization period",!
- KILL X
- QUIT
- +1 IF $DATA(FBTRT)
- IF $DATA(FBLTD)
- IF (9999999.999999-Y)'<FBLTD
- WRITE !,*7,"There is already an existing admission for this authorization!",!
- KILL X
- +2 QUIT
- DATCK3 IF $DATA(FBLTTYP)
- IF FBLTTYP]""
- IF FBLTTYP<4
- IF (X-3)'=FBLTTYP
- WRITE !!,*7,"That transfer type NOT consistent with last transfer type!",!
- KILL X
- +1 IF $DATA(FBLTT)
- IF FBLTT="A"
- IF X>3
- WRITE !!,*7,"A 'Transfer From' type transaction can only follow a 'Transfer To' type!",!
- KILL X
- +2 QUIT
- WRONGT ;WRONG TYPE OF AUTHORIZATION SELECTED
- +1 WRITE !!,"Authorization type selected inconsistent with option being used"
- QUIT
- GETVEN ;LOOKUP VENDOR
- +1 WRITE !
- SET DIC=161.2
- SET DIC(0)="AEQM"
- SET IFN=""
- DO ^DIC
- if Y<0
- QUIT
- SET IFN=+Y
- QUIT
- HANG ;IF $E(IOST,1,2)["C-" ASK TO CONTINUE
- +1 SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- if 'Y
- SET FBAAOUT=1
- QUIT
- CKOB DO STATION^FBAAUTL
- IF $DATA(FB("ERROR"))
- KILL FB("ERROR"),X
- QUIT
- +1 SET PRC("SITE")=$SELECT($DATA(PRC("SITE")):PRC("SITE"),1:FBSN)
- KILL FBSN,FBAASN
- +2 IF '$DATA(^PRC(442,"B",PRC("SITE")_"-"_X))
- WRITE !,"This Obligation number does not exist in the IFCAP file!",!
- KILL PRC,X
- +3 QUIT
- CK1358 ;CHECK TO SEE IF 1358 AVAILABLE
- +1 ;FBAAOB=FULL OBLIGATION NUMBER (STA-CXXXXX)
- +2 ;RETURNS Y=1 IF OK
- +3 SET PRCS("X")=FBAAOB
- SET PRCS("TYPE")="FB"
- DO EN3^PRCS58
- IF Y=-1
- WRITE !!,*7,"1358 not available for posting!",!
- SET FBERR=1
- QUIT
- +4 QUIT
- NOAUTH SET (FTP,X)=""
- QUIT
- LOCK WRITE !!,*7,"Queueing has been initiated by another user and is now in progress!",!!
- QUIT
- +1 ;
- XSET ;SET X-REF IN FILE 161.27 FOR LOOK-UP BY SHORT DESCRIPTION
- +1 SET ZZ=^FBAA(161.27,DA,2)
- DO TRANS
- SET ^FBAA(161.27,"C",$EXTRACT(ZZ,1,30),DA)=""
- +2 KILL ZZ
- QUIT
- XKILL ;
- +1 SET ZZ=^FBAA(161.27,DA,2)
- DO TRANS
- KILL ^FBAA(161.27,"C",$EXTRACT(ZZ,1,30),DA)
- +2 KILL ZZ
- QUIT
- +3 ;
- TRANS ;
- +1 SET ZZ=$TRANSLATE(ZZ,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
- +2 QUIT
- +3 ;
- VER() ;no parameters passed
- +1 ;returns 1 if site is running version 4 of IFCAP
- +2 ;S X=$G(^DIC(9.4,+$O(^DIC(9.4,"C","PRC",0)),"VERSION"))
- +3 NEW X
- +4 SET X=$$VERSION^XPDUTL("PRC")
- +5 QUIT $SELECT(+X=4:1,1:0)
- +6 ;
- ADD ;call to add money back into 1358 when version of IFCAP>3.6
- +1 ;uses interface ID look-up to get internal entry number
- +2 ;interface ID = IEN of batch from 161.7
- +3 ;find ien to 424 by $O(^PRC(424,"E",FBN,0))
- +4 ;call NOT used for civil hospital/cnh
- +5 SET PRCS("X")=FBAAOB
- SET PRCS("TYPE")="FB"
- DO EN3^PRCS58
- IF Y=-1
- WRITE !!,*7,"1358 not available for posting!",!
- SET FBERR=1
- QUIT
- +6 NEW FBADDX
- SET FBADDX=$ORDER(^PRC(424,"E",+$GET(FBN),0))
- IF 'FBADDX
- SET FBERR=1
- QUIT
- +7 DO NOW^%DTC
- +8 SET PRCSX=FBADDX_"^"_%_"^"_FBAAMT_"^"_FBCOMM_"^"_1
- +9 DO ^PRCS58CC
- IF Y'=1
- WRITE !!,*7,$PIECE(Y,U,2),!
- SET FBERR=1
- +10 QUIT
- +11 ;
- ASKVET(FBSCR) ; Prompt for patient
- +1 ; input FBSCR - (optional) screen logic for DIC lookup
- +2 ; e.g. I $D(^FBAAC("AH",12,+Y))
- +3 ; returns IEN of patient in file 161 or 0 if none selected
- +4 NEW DIC,FBRET,Y
- +5 SET FBRET=0
- +6 WRITE !!
- +7 SET DIC="^FBAAA("
- +8 SET DIC(0)="AQEM"
- +9 if $GET(FBSCR)'=""
- SET DIC("S")=FBSCR
- +10 DO ^DIC
- +11 IF Y'<0
- SET FBRET=+Y
- +12 QUIT FBRET