FBAAUTL1 ;AISC/GRR-Fee Basis Utility Routine ;1/13/98 ;;3.5;FEE BASIS;**3,12,13**;JAN 30, 1995 ;;Per VHA Directive 10-93-142, 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) Q 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),YFBAAEDT) W !!,*7,"Date ",$S(Y3 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