source: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAAUTL1.m@ 767

Last change on this file since 767 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.4 KB
Line 
1FBAAUTL1 ;AISC/GRR-Fee Basis Utility Routine ;1/13/98
2 ;;3.5;FEE BASIS;**3,12,13**;JAN 30, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4PLUSOB ;ENTRY POINT TO INCREASE OBLIGATION ADJUSTMENT
5 S FBAAMT="-"_FBAARA
6 D ADD Q
7 ;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
8 Q
9VALCK ;DETERMINE VALIDITY OF RESPONSE
10 S VAL=0 I $E(X)="?"!("YyNn"'[$E(X,1)) D HELPYN Q
11 S VAL=1
12 Q
13HELPYN ;DISPLAY HELP TEXT FOR YES OR NO
14 W !!,"Please enter 'Yes' or 'No'."
15 Q
16GETVET 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
17 Q
18GETAUTH S CNT=0,FTP="" N FB,FBFDT
19 I '$D(^FBAAA(DFN,1)) W !!,"PATIENT HAS NO AUTHORIZATIONS " Q
20 S FBPROG=$S($D(FBPROG):FBPROG,1:"I 1")
21 S FBFDT=9999999 F S FBFDT=$O(^FBAAA(DFN,1,"B",FBFDT),-1) Q:'FBFDT D
22 . 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
23 S PI="" D HOME^%ZIS D ^FBAADEM
24 I CNT<1 W !!,"Veteran does NOT have an Authorization for the Fee Program being used !!" G Q
25RD 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
26CHOOS W !! S DIR(0)="N^1:"_CNT D ^DIR K DIR S X=+Y Q:$D(DUOUT) G H^XUS:$D(DTOUT)
272 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=""
28 I $P(FB,"^",9)[";FB7078(" S FB7078=+$P(FB,"^",9)
29 I $P(FB,"^",9)[";FB583(" S FB583=+$P(FB,"^",9)
30 S FBDMRA=$G(^FBAAA(DFN,1,X,"ADEL")) I FBDMRA']"" K FBDMRA
31 S FBASSOC=X
32 I FB7078]"" S FBVEN=+$P($G(^FB7078(+FB7078,0)),U,2)
33Q Q
34DAYS ;CALCULATES THE NUMBER OF DAYS IN MONTH
35 S X1=X,X=+$E(X,4,5),X=$S("^1^3^5^7^8^10^12^"[("^"_X_"^"):31,X=2:28,1:30)
36 I X=28 D
37 . N YEAR
38 . S YEAR=$E(X1,1,3)+1700
39 . I $S(YEAR#400=0:1,YEAR#4=0&'(YEAR#100=0):1,1:0) S X=29
40 Q
41DATCK2 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
42 I $D(FBTRT),$D(FBLTD),(9999999.999999-Y)'<FBLTD W !,*7,"There is already an existing admission for this authorization!",! K X
43 Q
44DATCK3 I $D(FBLTTYP),FBLTTYP]"",FBLTTYP<4,(X-3)'=FBLTTYP W !!,*7,"That transfer type NOT consistent with last transfer type!",! K X
45 I $D(FBLTT),FBLTT="A",X>3 W !!,*7,"A 'Transfer From' type transaction can only follow a 'Transfer To' type!",! K X
46 Q
47WRONGT ;WRONG TYPE OF AUTHORIZATION SELECTED
48 W !!,"Authorization type selected inconsistent with option being used" Q
49GETVEN ;LOOKUP VENDOR
50 W ! S DIC=161.2,DIC(0)="AEQM",IFN="" D ^DIC Q:Y<0 S IFN=+Y Q
51HANG ;IF $E(IOST,1,2)["C-" ASK TO CONTINUE
52 S DIR(0)="E" D ^DIR K DIR S:'Y FBAAOUT=1 Q
53CKOB D STATION^FBAAUTL I $D(FB("ERROR")) K FB("ERROR"),X Q
54 S PRC("SITE")=$S($D(PRC("SITE")):PRC("SITE"),1:FBSN) K FBSN,FBAASN
55 I '$D(^PRC(442,"B",PRC("SITE")_"-"_X)) W !,"This Obligation number does not exist in the IFCAP file!",! K PRC,X
56 Q
57CK1358 ;CHECK TO SEE IF 1358 AVAILABLE
58 ;FBAAOB=FULL OBLIGATION NUMBER (STA-CXXXXX)
59 ;RETURNS Y=1 IF OK
60 S PRCS("X")=FBAAOB,PRCS("TYPE")="FB" D EN3^PRCS58 I Y=-1 W !!,*7,"1358 not available for posting!",! S FBERR=1 Q
61 Q
62NOAUTH S (FTP,X)="" Q
63LOCK W !!,*7,"Queueing has been initiated by another user and is now in progress!",!! Q
64 ;
65XSET ;SET X-REF IN FILE 161.27 FOR LOOK-UP BY SHORT DESCRIPTION
66 S ZZ=^FBAA(161.27,DA,2) D TRANS S ^FBAA(161.27,"C",$E(ZZ,1,30),DA)=""
67 K ZZ Q
68XKILL ;
69 S ZZ=^FBAA(161.27,DA,2) D TRANS K ^FBAA(161.27,"C",$E(ZZ,1,30),DA)
70 K ZZ Q
71 ;
72TRANS ;
73 S ZZ=$TR(ZZ,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
74 Q
75 ;
76VER() ;no parameters passed
77 ;returns 1 if site is running version 4 of IFCAP
78 ;S X=$G(^DIC(9.4,+$O(^DIC(9.4,"C","PRC",0)),"VERSION"))
79 N X
80 S X=$$VERSION^XPDUTL("PRC")
81 Q $S(+X=4:1,1:0)
82 ;
83ADD ;call to add money back into 1358 when version of IFCAP>3.6
84 ;uses interface ID look-up to get internal entry number
85 ;interface ID = IEN of batch from 161.7
86 ;find ien to 424 by $O(^PRC(424,"E",FBN,0))
87 ;call NOT used for civil hospital/cnh
88 S PRCS("X")=FBAAOB,PRCS("TYPE")="FB" D EN3^PRCS58 I Y=-1 W !!,*7,"1358 not available for posting!",! S FBERR=1 Q
89 N FBADDX S FBADDX=$O(^PRC(424,"E",+$G(FBN),0)) I 'FBADDX S FBERR=1 Q
90 D NOW^%DTC
91 S PRCSX=FBADDX_"^"_%_"^"_FBAAMT_"^"_FBCOMM_"^"_1
92 D ^PRCS58CC I Y'=1 W !!,*7,$P(Y,U,2),! S FBERR=1
93 Q
Note: See TracBrowser for help on using the repository browser.