Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: FBAAUTL1

FBAAUTL1.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. PLUSOB ;ENTRY POINT TO INCREASE OBLIGATION ADJUSTMENT
  1. S FBAAMT="-"_FBAARA
  1. D ADD Q
  1. ;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
  1. Q
  1. VALCK ;DETERMINE VALIDITY OF RESPONSE
  1. S VAL=0 I $E(X)="?"!("YyNn"'[$E(X,1)) D HELPYN Q
  1. S VAL=1
  1. Q
  1. HELPYN ;DISPLAY HELP TEXT FOR YES OR NO
  1. W !!,"Please enter 'Yes' or 'No'."
  1. Q
  1. 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
  1. Q
  1. GETAUTH S CNT=0,FTP="" N FB,FBFDT
  1. I '$D(^FBAAA(DFN,1)) W !!,"PATIENT HAS NO AUTHORIZATIONS " Q
  1. S FBPROG=$S($D(FBPROG):FBPROG,1:"I 1")
  1. S FBFDT=9999999 F S FBFDT=$O(^FBAAA(DFN,1,"B",FBFDT),-1) Q:'FBFDT D
  1. . 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
  1. S PI="" D HOME^%ZIS D ^FBAADEM
  1. I CNT<1 W !!,"Veteran does NOT have an Authorization for the Fee Program being used !!" G Q
  1. 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
  1. CHOOS W !! S DIR(0)="N^1:"_CNT D ^DIR K DIR S X=+Y Q:$D(DUOUT) G H^XUS:$D(DTOUT)
  1. 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=""
  1. I $P(FB,"^",9)[";FB7078(" S FB7078=+$P(FB,"^",9)
  1. I $P(FB,"^",9)[";FB583(" S FB583=+$P(FB,"^",9)
  1. S FBDMRA=$G(^FBAAA(DFN,1,X,"ADEL")) I FBDMRA']"" K FBDMRA
  1. S FBASSOC=X
  1. I FB7078]"" S FBVEN=+$P($G(^FB7078(+FB7078,0)),U,2)
  1. S FBCNTRA=$P(FB,"^",22)
  1. Q Q
  1. GETAUTHK ; kill new authorization variables output from GETAUTH
  1. K FBCNTRA
  1. Q
  1. DAYS ;CALCULATES THE NUMBER OF DAYS IN MONTH
  1. S X1=X,X=+$E(X,4,5),X=$S("^1^3^5^7^8^10^12^"[("^"_X_"^"):31,X=2:28,1:30)
  1. I X=28 D
  1. . N YEAR
  1. . S YEAR=$E(X1,1,3)+1700
  1. . I $S(YEAR#400=0:1,YEAR#4=0&'(YEAR#100=0):1,1:0) S X=29
  1. Q
  1. 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
  1. I $D(FBTRT),$D(FBLTD),(9999999.999999-Y)'<FBLTD W !,*7,"There is already an existing admission for this authorization!",! K X
  1. Q
  1. DATCK3 I $D(FBLTTYP),FBLTTYP]"",FBLTTYP<4,(X-3)'=FBLTTYP W !!,*7,"That transfer type NOT consistent with last transfer type!",! K X
  1. I $D(FBLTT),FBLTT="A",X>3 W !!,*7,"A 'Transfer From' type transaction can only follow a 'Transfer To' type!",! K X
  1. Q
  1. WRONGT ;WRONG TYPE OF AUTHORIZATION SELECTED
  1. W !!,"Authorization type selected inconsistent with option being used" Q
  1. GETVEN ;LOOKUP VENDOR
  1. W ! S DIC=161.2,DIC(0)="AEQM",IFN="" D ^DIC Q:Y<0 S IFN=+Y Q
  1. HANG ;IF $E(IOST,1,2)["C-" ASK TO CONTINUE
  1. S DIR(0)="E" D ^DIR K DIR S:'Y FBAAOUT=1 Q
  1. CKOB D STATION^FBAAUTL I $D(FB("ERROR")) K FB("ERROR"),X Q
  1. S PRC("SITE")=$S($D(PRC("SITE")):PRC("SITE"),1:FBSN) K FBSN,FBAASN
  1. I '$D(^PRC(442,"B",PRC("SITE")_"-"_X)) W !,"This Obligation number does not exist in the IFCAP file!",! K PRC,X
  1. Q
  1. CK1358 ;CHECK TO SEE IF 1358 AVAILABLE
  1. ;FBAAOB=FULL OBLIGATION NUMBER (STA-CXXXXX)
  1. ;RETURNS Y=1 IF OK
  1. S PRCS("X")=FBAAOB,PRCS("TYPE")="FB" D EN3^PRCS58 I Y=-1 W !!,*7,"1358 not available for posting!",! S FBERR=1 Q
  1. Q
  1. NOAUTH S (FTP,X)="" Q
  1. LOCK W !!,*7,"Queueing has been initiated by another user and is now in progress!",!! Q
  1. ;
  1. XSET ;SET X-REF IN FILE 161.27 FOR LOOK-UP BY SHORT DESCRIPTION
  1. S ZZ=^FBAA(161.27,DA,2) D TRANS S ^FBAA(161.27,"C",$E(ZZ,1,30),DA)=""
  1. K ZZ Q
  1. XKILL ;
  1. S ZZ=^FBAA(161.27,DA,2) D TRANS K ^FBAA(161.27,"C",$E(ZZ,1,30),DA)
  1. K ZZ Q
  1. ;
  1. TRANS ;
  1. S ZZ=$TR(ZZ,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1. Q
  1. ;
  1. VER() ;no parameters passed
  1. ;returns 1 if site is running version 4 of IFCAP
  1. ;S X=$G(^DIC(9.4,+$O(^DIC(9.4,"C","PRC",0)),"VERSION"))
  1. N X
  1. S X=$$VERSION^XPDUTL("PRC")
  1. Q $S(+X=4:1,1:0)
  1. ;
  1. 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
  1. ;interface ID = IEN of batch from 161.7
  1. ;find ien to 424 by $O(^PRC(424,"E",FBN,0))
  1. ;call NOT used for civil hospital/cnh
  1. S PRCS("X")=FBAAOB,PRCS("TYPE")="FB" D EN3^PRCS58 I Y=-1 W !!,*7,"1358 not available for posting!",! S FBERR=1 Q
  1. N FBADDX S FBADDX=$O(^PRC(424,"E",+$G(FBN),0)) I 'FBADDX S FBERR=1 Q
  1. D NOW^%DTC
  1. S PRCSX=FBADDX_"^"_%_"^"_FBAAMT_"^"_FBCOMM_"^"_1
  1. D ^PRCS58CC I Y'=1 W !!,*7,$P(Y,U,2),! S FBERR=1
  1. Q
  1. ;
  1. ASKVET(FBSCR) ; Prompt for patient
  1. ; input FBSCR - (optional) screen logic for DIC lookup
  1. ; e.g. I $D(^FBAAC("AH",12,+Y))
  1. ; returns IEN of patient in file 161 or 0 if none selected
  1. N DIC,FBRET,Y
  1. S FBRET=0
  1. W !!
  1. S DIC="^FBAAA("
  1. S DIC(0)="AQEM"
  1. S:$G(FBSCR)'="" DIC("S")=FBSCR
  1. D ^DIC
  1. I Y'<0 S FBRET=+Y
  1. Q FBRET