source: FOIAVistA/trunk/r/FEE_BASIS-FB/FBAAUTL.m@ 1288

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

initial load of FOIAVistA 6/30/08 version
File size: 4.9 KB
Line 
1FBAAUTL ;AISC/GRR,SBW-Fee Basis Utility Routine ;7/NOV/2006
2 ;;3.5;FEE BASIS;**101**;JAN 30, 1995;Build 2
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4DATE N FBDT S FBPOP=0 K BEGDATE,ENDDATE K:$G(%DT)'["A" %DT W !!,"**** Date Range Selection ****"
5 S FBDT=$S($D(%DT):1,1:0) W ! S %DT=$S(FBDT:%DT,1:"APEX"),%DT("A")=" Beginning DATE : " D ^%DT S:Y<0 FBPOP=1 Q:Y<0 S (%DT(0),BEGDATE)=Y
6 W ! S %DT=$S(FBDT:%DT,1:"AEX"),%DT("A")=" Ending DATE : " D ^%DT K %DT S:Y<0 FBPOP=1 Q:Y<0 W ! S ENDDATE=Y
7 Q
8 ;
9ZIS S ZTRTN=PGM,ZTSAVE="",FBPOP=0 F I=1:1 Q:$P(VAR,"^",I)']"" S ZTSAVE($P(VAR,"^",I))=""
10 I '$D(ZTDESC) S ZTDESC=$S($D(PGM):PGM,1:"UNKNOWN OPTION")
11 W ! S %ZIS="QMP" D ^%ZIS S:POP FBPOP=1 Q:POP I $D(IO("Q")) K IO("Q"),ZTIO D ^%ZTLOAD W:$D(ZTSK) !,*7,"REQUEST QUEUED",!,"Task #: ",$G(ZTSK) K I,ZTSK,ZTIO,ZTSAVE,ZTRTN D HOME^%ZIS S FBPOP=1 Q
12 Q
13 ;
14CLOSE I '$D(ZTQUEUED) D ^%ZISC
15 K IOP,ZTDESC,ZTRTN,ZTSAVE,ZTDTH,VAR,VAL,PGM,FBPOP,POP Q
16 ;
17D S Y=$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",$E(Y,4,5))_" "_$S(Y#100:$J(Y#100\1,2)_",",1:"")_(Y\10000+1700)_$S(Y#1:" "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12),1:"") Q
18SITEP ;SET FBSITE(0),FBSITE(1) VARIABLE TO FEE SITE PARAMETERS
19 S FBPOP=0,FBSITE(0)=$G(^FBAA(161.4,1,0)) S:FBSITE(0)']"" FBPOP=1
20 S FBSITE(1)=$G(^FBAA(161.4,1,1)) S:FBSITE(1)']"" FBPOP=1
21 W:FBPOP !,*7,"Fee Basis Site Parameters must be entered to proceed",!
22 Q
23TM S X=$E($P(X,".",2)_"0000",1,4),%=X>1159 S:X>1259 X=X-1200 S X=X\100_":"_$E(X#100+100,2,3)_" "_$E("AP",%+1)_"M" Q
24PDF S:Y Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) Q
25GETNXB ;GET NEXT AVAILABLE BATCH NUMBER
26 L +^FBAA(161.4) I '$D(^FBAA(161.4,1,"FBNUM")) S ^FBAA(161.4,1,"FBNUM")="1^1"
27 I '$P($G(^FBAA(161.4,1,"FBNUM")),"^") S $P(^("FBNUM"),"^")=1
28 S FBBN=$P(^FBAA(161.4,1,"FBNUM"),"^")
29 I FBBN>99899,$S('$D(^FBAA(161.4,1,"PURGE")):1,$P(^FBAA(161.4,1,"PURGE"),"^",1)'>0:1,1:"") D WARNBT
30 S $P(^FBAA(161.4,1,"FBNUM"),"^",1)=$S(FBBN+1>99999:1,1:FBBN+1) I '$$CHKBI^FBAAUTL4(FBBN,1) L -^FBAA(161.4) G GETNXB
31 L -^FBAA(161.4) Q
32WARNBT W !,*7,"There are ",99999-FBBN," batches left before the BATCH PURGE routine",!,"needs to be run. Contact your IRM Service!",!!
33 Q
34GETNXI ;GET NEXT AVAILABLE INVOICE NUMBER
35 L +^FBAA(161.4) I '$D(^FBAA(161.4,1,"FBNUM")) S ^FBAA(161.4,1,"FBNUM")="1^1"
36 I '$P($G(^FBAA(161.4,1,"FBNUM")),U,2) S $P(^("FBNUM"),U,2)=1
37 S FBAAIN=$P(^FBAA(161.4,1,"FBNUM"),"^",2),$P(^("FBNUM"),"^",2)=$S(FBAAIN+1>9999999:1,1:FBAAIN+1) I '$$CHKBI^FBAAUTL4(FBAAIN) L -^FBAA(161.4) G GETNXI
38 L -^FBAA(161.4) Q
39PDATE S FBPDT=$P("January^February^March^April^May^June^July^August^September^October^November^December","^",$E(Y,4,5))_" "_$S(Y#100:$J(Y#100\1,2)_", ",1:"")_(Y\10000+1700)_$S(Y#1:" "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12),1:"") Q
40DATCK S HOLDY=Y,HOLDY=$S($P(HOLDY,"^",2):$P(HOLDY,"^",2),1:HOLDY)
41 I $D(FBAAID),Y>FBAAID W !!,*7,"Date of Service cannot be later than Invoice Date!" K X Q
42 I $D(FBAABDT),$D(FBAAEDT),(Y<FBAABDT!(Y>FBAAEDT)) W !!,*7,"Date of Service ",$S(Y<FBAABDT:"prior to ",1:"later than "),"Authorization period.",! K X
43 S Y=HOLDY Q
44 ;
45DATX(X) ;external output function for date format
46 ;INPUT = FM internal date format (time optional)
47 ;OUTPUT = date/time with slashes
48 Q $$FMTE^XLFDT(X,2)
49 ;
50STATION ;GET STATION NUMBER FROM INSTITUTION FILE
51 I '$D(FBSITE(1)) D SITEP
52 I $S('$D(FBSITE(1)):1,$P(FBSITE(1),"^",3)="":1,'$D(^DIC(4,$P(FBSITE(1),"^",3),0)):1,'$D(^DIC(4,$P(FBSITE(1),"^",3),99)):1,'+$P(^DIC(4,$P(FBSITE(1),"^",3),99),"^"):1,1:0) G NOSTA
53 S (FBSN,FBAASN)=$S($D(^DIC(4,$P(FBSITE(1),"^",3),99)):$E(^(99),1,3),1:999)
54 Q
55NOSTA S FB("ERROR")=1 I '$D(ZTQUEUED) W !!,*7,"Unable to determine Station Number. Check Fee Site Parameters or Station Number in the Institution File.",!!
56 Q
57 ;
58HD ;set transmission header
59 I '$D(FBSITE(1)) S FBSITE(1)=$G(^FBAA(161.4,1,1))
60 S FBHD=$$HDR^FBAAUTL3() I FBHD']"" S FB("ERROR")=1 W !,"Transmission header must exist in FEE BASIS SITE PARAMETER file",!,"before you can proceed.",*7,!
61 Q
62 ;
63SSN(PID,BID,DOD) ;
64 ;PID = DFN of Patient. If this is all that is past,
65 ;full Pt.ID (000-00-0000) will be returned.
66 ;If BID = 1 the call will return last 4 of Pt.ID only.
67 ;If DOD is defined to internal entry # of eligibility the appropriate
68 ;Pt.ID will be returned.
69 N DFN,FBSSN
70 S DFN=PID
71 I 'DFN Q "Unknown"
72 S:'$D(BID) BID="" S:$D(DOD) VAPTYP=DOD
73 D PID^VADPT6 I VAERR K VAERR Q "Unknown"
74 S FBSSN=$S(BID:VA("BID"),1:VA("PID"))
75 K VA("BID"),VA("PID"),VAERR,VAPTYP
76 Q FBSSN
77 ;
78SSNL4(SSN) ;Convert 1st 5 digits of SSN to X (Only print last 4 digits of SSN)
79 ;Input:
80 ; SSN - SSN in 9 digit or ###-##-#### format
81 ; Pseudo SSN is also allowed as input
82 ;Output
83 ; SSN - SSN in XXXXX#### or XXX-XX-#### format
84 ; Pseudo SSN will be changed as above with passed "P" at end
85 ; X represent actual X and # represent digit
86 ;
87 S SSN=$G(SSN)
88 ;Change SSN ######### to XXXXX####
89 S:SSN?9N0.1"P" $E(SSN,1,5)="XXXXX"
90 ;Change SSN ###-##-#### to XXX-XX-####
91 S:SSN?3N1"-"2N1"-"4N0.1"P" $E(SSN,1,7)="XXX-XX-"
92 Q SSN
Note: See TracBrowser for help on using the repository browser.