source: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBCKDIS1.m@ 1482

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

initial load of WorldVistAEHR

File size: 2.2 KB
RevLine 
[613]1FBCKDIS1 ;AISC/CMR - OUTPUT BY CHECK # cont. ;20APR94
2 ;;3.5;FEE BASIS;;JAN 30, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 D OPT,INPT,PHARM,TRAV
5 Q
6OPT ;find outpatient payments for check #
7 Q:'$D(^FBAAC("ACK",FBCN))
8 S FBPROG="OPT",FBCNT=0
9 S FB1=0 F S FB1=$O(^FBAAC("ACK",FBCN,FB1)) Q:'FB1 S FB2=0 F S FB2=$O(^FBAAC("ACK",FBCN,FB1,FB2)) Q:'FB2 S FB3=0 F S FB3=$O(^FBAAC("ACK",FBCN,FB1,FB2,FB3)) Q:'FB3 S FB4=0 F S FB4=$O(^FBAAC("ACK",FBCN,FB1,FB2,FB3,FB4)) Q:'FB4 D
10 .Q:$S('$D(^FBAAC(FB1,1,FB2,1,FB3,1,FB4,0)):1,'$D(^FBAAC(FB1,1,FB2,1,FB3,1,FB4,2)):1,'$D(^FBAAC(FB1,1,FB2,1,FB3,0)):1,1:0)
11 .S FBCNT=FBCNT+1,FBDA=FB1_"^"_FB2_"^"_FB3_"^"_FB4,DFN=FB1,FBV=FB2
12 .D SETMP
13 D CLN Q
14INPT ;find inpatient payments for check #
15 Q:'$D(^FBAAI("ACK",FBCN))
16 S (FBCNTCH,FBCNTCNH)=0
17 S FB1=0 F S FB1=$O(^FBAAI("ACK",FBCN,FB1)) Q:'FB1 D
18 .Q:$S('$D(^FBAAI(FB1,0)):1,'$D(^FBAAI(FB1,2)):1,1:0)
19 .S FBA=^FBAAI(FB1,0),DFN=$P(FBA,U,4),FBV=$P(FBA,U,3)
20 .S FBPROG=$S($P(FBA,U,12)=6:"CH",$P(FBA,U,12)=7:"CNH",1:"") Q:FBPROG']""
21 .I FBPROG="CH" S FBCNTCH=FBCNTCH+1,FBCNT=FBCNTCH
22 .I FBPROG="CNH" S FBCNTCNH=FBCNTCNH+1,FBCNT=FBCNTCNH
23 .S FBDA=FB1
24 .D SETMP
25 D CLN Q
26PHARM ;find pharmacy payments for check #
27 Q:'$D(^FBAA(162.1,"ACK",FBCN))
28 S FBCNT=0,FBPROG="PHAR"
29 S FB1=0 F S FB1=$O(^FBAA(162.1,"ACK",FBCN,FB1)) Q:'FB1 S FB2=0 F S FB2=$O(^FBAA(162.1,"ACK",FBCN,FB1,FB2)) Q:'FB2 D
30 .Q:$S('$D(^FBAA(162.1,FB1,"RX",FB2,0)):1,'$D(^FBAA(162.1,FB1,"RX",FB2,2)):1,'$D(^FBAA(162.1,FB1,0)):1,1:0)
31 .S FBCNT=FBCNT+1
32 .S FBA=^FBAA(162.1,FB1,"RX",FB2,0),DFN=$P(FBA,U,5),FBV=$P(^FBAA(162.1,FB1,0),U,4)
33 .S FBDA=FB1_"^"_FB2
34 .D SETMP
35 D CLN Q
36TRAV ;find travel payments for check #
37 Q:'$D(^FBAAC("ACKT",FBCN))
38 S FBCNT=0,FBPROG="TRAV"
39 S FB1=0 F S FB1=$O(^FBAAC("ACKT",FBCN,FB1)) Q:'FB1 S FB2=0 F S FB2=$O(^FBAAC("ACKT",FBCN,FB1,FB2)) Q:'FB2 D
40 .Q:'$D(^FBAAC(FB1,3,FB2,0))
41 .S FBCNT=FBCNT+1
42 .S DFN=FB1,FBV="R"
43 .S FBDA=FB1_"^"_FB2
44 .D SETMP
45 D CLN Q
46SETMP ;set up tmp global
47 S ^TMP($J,"FBCK",FBPROG,FBV,DFN,FBCNT)=FBDA
48 Q
49CLN K FB1,FB2,FB3,FB4,FBA,FBCNT,DFN,FBCNTCH,FBCNTCNH,FBPROG Q
50SUSP ;get suspense code
51 S FBSUSP=$S(FBSUSP="":"",$D(^FBAA(161.27,FBSUSP,0)):^FBAA(161.27,FBSUSP,0),1:"")
52 Q
Note: See TracBrowser for help on using the repository browser.