source: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBCKDIS.m@ 1639

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

initial load of WorldVistAEHR
File size: 7.0 KB
Line 
1FBCKDIS ;AISC/CMR-OUTPUT BY CHECK # ;7/NOV/2006
2 ;;3.5;FEE BASIS;**4,61,101**;JAN 30, 1995;Build 2
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;FBCN=Check Number FBPROG=Fee payment type
5 ;FBPR is set if called from the phone menu. If this variable exists,
6 ; the user will not be returned to the TOP to select another ck #.
7TOP W ! S DIR(0)="FO^1:8",DIR("A")="Select Check Number" D ^DIR K DIR Q:Y=""!(Y="^") S FBCN=Y
8 I '$D(^FBAAC("ACK",FBCN)),('$D(^FBAAC("ACKT",FBCN))),('$D(^FBAAI("ACK",FBCN))),('$D(^FBAA(162.1,"ACK",FBCN))) W !!,*7,"There is no record of that check number." G TOP
9 S VAR="FBCN",VAL=FBCN,PGM="START^FBCKDIS" D ZIS^FBAAUTL G END:FBPOP
10START S Q="-",$P(Q,"-",80)="-",QQ="=",$P(QQ,"=",80)="=",FBPG=1 K ^TMP($J,"FBCK")
11 N FBV,DFN D ^FBCKDIS1
12 U IO W:$E(IOST,1,2)["C-" @IOF
13 F FBPROG="OPT","CH","CNH","PHAR","TRAV" I $D(^TMP($J,"FBCK",FBPROG)) D PGCHK D Q:$G(FBAAOUT)
14 .S FBV=0 F S FBV=$O(^TMP($J,"FBCK",FBPROG,FBV)) Q:FBV']""!($G(FBAAOUT)) W:FBPROG'="TRAV" !!,"VENDOR: ",$$VNAME^FBNHEXP(FBV),?40," VENDOR ID: ",$$VID^FBNHEXP(FBV) D
15 ..S DFN=0 F S DFN=$O(^TMP($J,"FBCK",FBPROG,FBV,DFN)) Q:'DFN!($G(FBAAOUT)) D:$Y+8>IOSL PGCHK Q:$G(FBAAOUT) W !!,"Patient: ",$$NAME^FBCHREQ2(DFN),?40,"Patient ID: ",$$SSNL4^FBAAUTL($$SSN^FBAAUTL(DFN)) D
16 ...N FBAARC,FBADJLA,FBADJLR,FBC,FBFPPSC,FBFPPSL,FBSUSPA,FBX
17 ...S FBCNT=0 F S FBCNT=$O(^TMP($J,"FBCK",FBPROG,FBV,DFN,FBCNT)) Q:'FBCNT!($G(FBAAOUT)) S FBDA=^(FBCNT) D @FBPROG,OUTPUT,CLEAN
18END K FBCN,FBCNT,DFN,FBV,FBPROG,FBPG,DIRUT,DTOUT,DUOUT,Q,QQ,^TMP($J,"FBCK")
19 D CLOSE^FBAAUTL
20 I $G(FBAAOUT) K FBAAOUT Q
21 Q:$G(FBPR)]""!($G(ZTQUEUED))
22 W !! S DIR(0)="E" D ^DIR K DIR Q:'Y G TOP
23OPT ;gather payment line item for outpatient
24 F I=1:1:4 S FB(I)=+$P(FBDA,U,I)
25 S FBA=^FBAAC(FB(1),1,FB(2),1,FB(3),1,FB(4),0),FBB=^(2),FBC=$G(^(3))
26 S FBDOS=+^FBAAC(FB(1),1,FB(2),1,FB(3),0)
27 S FBSRV=$$CPT^FBAAUTL4($P(FBA,U))
28 S FBMODLE=$$MODL^FBAAUTL4("^FBAAC("_FB(1)_",1,"_FB(2)_",1,"_FB(3)_",1,"_FB(4)_",""M"")","E")
29 S FBSRV=FBSRV_$S($G(FBMODLE)]"":"-"_FBMODLE,1:"")
30 S FBAMCL=$P(FBA,U,2),FBAMPD=$P(FBA,U,3)
31 S FBSUSP=$P(FBA,U,5) D SUSP^FBCKDIS1
32 S FBSUSPA=$FN($P(FBA,U,4),"",2)
33 S FBFPPSC=$P(FBC,U)
34 S FBFPPSL=$P(FBC,U,2)
35 S FBAARCE=$$GET1^DIQ(162.03,FB(4)_","_FB(3)_","_FB(2)_","_FB(1)_",",48)
36 S FBX=$$ADJLRA^FBAAFA(FB(4)_","_FB(3)_","_FB(2)_","_FB(1)_",")
37 S FBADJLR=$P(FBX,U)
38 S FBADJLA=$P(FBX,U,2)
39 S FBVP=$P(FBA,U,21),FBREIM=$P(FBA,U,20),FBBAT=$P(FBA,U,8),FBINV=$P(FBA,U,16)
40 D FBCKO^FBAACCB2(FB(1),FB(2),FB(3),FB(4))
41 Q
42CH ;gather payment line item for ch
43CNH ;gather payment line item for cnh
44 S FBA=^FBAAI(FBDA,0),FBB=^(2),FBC=$G(^(3)),FBDOS=$P(FBA,U,6)_"-"_$P(FBA,U,7),FBAMCL=$P(FBA,U,8),FBAMPD=$P(FBA,U,9),FBSUSP=$P(FBA,U,11) D SUSP^FBCKDIS1
45 S FBVP=$P(FBA,U,14),FBREIM=$P(FBA,U,13),FBBAT=$P(FBA,U,17),FBINV=+FBA
46 S FBSUSPA=$FN($P(FBA,U,10),"",2)
47 S FBFPPSC=$P(FBC,U)
48 S FBFPPSL=$P(FBC,U,2)
49 S FBX=$$ADJLRA^FBCHFA(FBDA_",")
50 S FBADJLR=$P(FBX,U)
51 S FBADJLA=$P(FBX,U,2)
52 D FBCKI^FBAACCB1(FBDA)
53 Q
54PHAR ;gather payment line item for pharmacy
55 F I=1,2 S FB(I)=$P(FBDA,U,I)
56 S FBA=^FBAA(162.1,FB(1),"RX",FB(2),0),FBB=^(2),FBC=$G(^(3)),FBDOS=$P(FBA,U,3),FBSRV=$P(FBA,"^"),FBAMCL=$P(FBA,U,4),FBAMPD=$P(FBA,U,16),FBSUSP=$P(FBA,U,8) D SUSP^FBCKDIS1
57 S FBVP=$P(FBB,U,3),FBREIM=$P(FBA,U,20),FBBAT=$P($G(FBA),U,17),FBINV=+$G(^FBAA(162.1,FB(1),0))
58 S FBSUSPA=$FN($P(FBA,U,7),"",2)
59 S FBFPPSC=$P($G(^FBAA(162.1,FB(1),0)),U,13)
60 S FBFPPSL=$P(FBC,U)
61 S FBX=$$ADJLRA^FBRXFA(FB(2)_","_FB(1)_",")
62 S FBADJLR=$P(FBX,U)
63 S FBADJLA=$P(FBX,U,2)
64 D FBCKP^FBAACCB1(FB(1),FB(2))
65 Q
66TRAV ;gather payment line item for travel
67 F I=1,2 S FB(I)=$P(FBDA,U,I)
68 S FBA=^FBAAC(FB(1),3,FB(2),0),FBDOS=+FBA,FBAMCL=$P(FBA,U,3),FBAMPD=FBAMCL,FBVP="",FBREIM="R",FBBAT=$P(FBA,U,2),FBINV=""
69 D FBCKT^FBAACCB0(FB(1),FB(2))
70 Q
71CLEAN ;clean up variables
72 K I,FB,FBA,FBB,FBDOS,FBSRV,FBMOD,FBAMCL,FBAMPD,FBSUSP,FBVP,FBREIM,FBBAT,FBINV,FBDA,FBMODLE
73 Q
74OUTPUT ;display line items for check number
75 I $Y+5>IOSL D PGCHK Q:$G(FBAAOUT)
76 W ! W:FBVP="VP" "#" W:FBREIM="R" "*" W:FBCAN]"" "+" D Q:$G(FBAAOUT)
77 . I FBPROG["C" D Q
78 . . W ?3,$$DATX^FBAAUTL($P(FBDOS,"-")),?15,$$DATX^FBAAUTL($P(FBDOS,"-",2)),?59,+$G(^FBAA(161.7,+FBBAT,0)),?68,FBINV
79 . . W !?3,$J($FN(FBAMCL,",",2),10),?15,$J($FN(FBAMPD,",",2),10)
80 . . ; write adjustment reasons, if null then write suspend code
81 . . W ?28,$S(FBADJLR]"":FBADJLR,1:FBSUSP)
82 . . ; write adjustment amounts, if null then write amount suspended
83 . . W ?38,$S(FBADJLA]"":FBADJLA,1:FBSUSPA)
84 . . I FBFPPSC]"" W !,?12,"FPPS Claim ID: ",FBFPPSC,?40,"FPPS Line Item: ",FBFPPSL
85 . I FBPROG="OPT" D Q
86 . . W ?3,$$DATX^FBAAUTL(FBDOS),?13,$P(FBSRV,","),?23,FBAARCE
87 . . W ?59,+$G(^FBAA(161.7,+FBBAT,0)),?68,FBINV
88 . . I $P(FBSRV,",",2)]"" D Q:$G(FBAAOUT)
89 . . . N FBI,FBMOD
90 . . . F FBI=2:1 S FBMOD=$P(FBSRV,",",FBI) Q:FBMOD="" D Q:$G(FBAAOUT)
91 . . . . I $Y+5>IOSL D PGCHK Q:$G(FBAAOUT) W !," (continued)"
92 . . . . W !,?18,"-",FBMOD
93 . . W !?3,$J($FN(FBAMCL,",",2),10),?15,$J($FN(FBAMPD,",",2),10)
94 . . ; write adjustment reasons, if null then write suspend code
95 . . W ?28,$S(FBADJLR]"":FBADJLR,1:FBSUSP)
96 . . ; write adjustment amounts, if null then write amount suspended
97 . . W ?38,$S(FBADJLA]"":FBADJLA,1:FBSUSPA)
98 . . I FBFPPSC]"" W !,?12,"FPPS Claim ID: ",FBFPPSC,?40,"FPPS Line Item: ",FBFPPSL
99 . I FBPROG="PHAR" D Q
100 . . W ?3,$$DATX^FBAAUTL(FBDOS),?13,FBSRV,?59,+$G(^FBAA(161.7,+FBBAT,0)),?68,FBINV
101 . . W !?3,$J($FN(FBAMCL,",",2),10),?15,$J($FN(FBAMPD,",",2),10)
102 . . ; write adjustment reasons, if null then write suspend code
103 . . W ?28,$S(FBADJLR]"":FBADJLR,1:FBSUSP)
104 . . ; write adjustment amounts, if null then write amount suspended
105 . . W ?38,$S(FBADJLA]"":FBADJLA,1:FBSUSPA)
106 . . I FBFPPSC]"" W !,?12,"FPPS Claim ID: ",FBFPPSC,?40,"FPPS Line Item: ",FBFPPSL
107 . W ?3,$$DATX^FBAAUTL(FBDOS) W:FBPROG'="TRAV" ?13,FBSRV W ?20,$J($FN(FBAMCL,",",2),10),?32,$J($FN(FBAMPD,",",2),10) W:FBPROG'="TRAV" ?47,FBSUSP W ?53,+$G(^FBAA(161.7,+FBBAT,0)),?65,FBINV
108 S A2=FBAMPD D PMNT^FBAACCB2 K A2
109 Q
110HED W !?20,"PAYMENT HISTORY FOR CHECK # ",FBCN,!,?20,$E(Q,1,(28+$L(FBCN))),?70,"Page: ",FBPG
111 W !!,?22,"FEE PROGRAM: ",$S(FBPROG="OPT":"OUTPATIENT",FBPROG="CH":"CIVIL HOSPITAL",FBPROG="CNH":"COMMUNITY NURSING HOME",FBPROG="PHAR":"PHARMACY",FBPROG="TRAV":"TRAVEL",1:"")
112 W !?1,"('*' Reimbursement to Patient '#' Voided Payment '+' Cancellation Activity)"
113 I FBPROG["C" D Q
114 . W !?3,"From Date",?15,"To Date",?59,"Batch #",?68,"Invoice #"
115 . W !?3,"Amt Claimed",?17,"Amt Paid",?28,"Adj Code",?38,"Adj Amount"
116 . W !,QQ
117 I FBPROG="TRAV" W !?3,"Travel Dt",?21,"Amount",?33,"Amount",?50,"Batch",?62,"Invoice",!,?21,"Claimed",?34,"Paid",?50,"Number",?62,"Number",!,QQ Q
118 I FBPROG="OPT" D Q
119 . W !?3,"Svc Date",?13,"CPT-MOD",?23,"Rev.Code",?59,"Batch #",?68,"Invoice #"
120 . W !?3,"Amt Claimed",?17,"Amt Paid",?28,"Adj Code",?38,"Adj Amount"
121 . W !,QQ
122 I FBPROG="PHAR" D Q
123 . W !?3,"Fill Dt",?13,"RX #",?56,"Batch #",?68,"Invoice #"
124 . W !?3,"Amt Claimed",?17,"Amt Paid",?28,"Adj Code",?38,"Adj Amount"
125 . W !,QQ
126 Q
127PGCHK I FBPG>1,($E(IOST,1,2)["C-") W !! S DIR(0)="E" D ^DIR K DIR I 'Y S FBAAOUT=1 Q
128 W:FBPG>1 @IOF D HED
129 S FBPG=FBPG+1 Q
Note: See TracBrowser for help on using the repository browser.