source: FOIAVistA/trunk/r/FEE_BASIS-FB/FBAASLP.m@ 1208

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

initial load of FOIAVistA 6/30/08 version
File size: 7.3 KB
Line 
1FBAASLP ;AISC/GRR-PRINT SUSPENSION LETTERS ;7/NOV/2006
2 ;;3.5;FEE BASIS;**12,4,23,69,101**;JAN 30, 1995;Build 2
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 D DATE^FBAAUTL G END:FBPOP K FBAAS S (FBAAOUT,FBSLW,FBPRG,FBCTR,FBY)=0,UL="",$P(UL,"=",80)="="
5 D ^FBAASL G END:FBAAOUT
6RDCODE S DIR(0)="Y",DIR("A")="For All Suspension codes",DIR("B")="YES",DIR("?")="'Yes' to print suspension letters for all suspension codes, 'No' to select specific codes." D ^DIR K DIR W ! G END:$D(DUOUT),END:$D(DTOUT),SEL:'Y
7 ;ask edi/non-edi/all claims
8AHEAD S DIR(0)="SA^1:EDI;2:NON-EDI;3:ALL",DIR("A")="Only print letters for claims that were submitted via (EDI/NON-EDI/ALL):",DIR("B")="ALL"
9 S DIR("?",1)=" Enter EDI to just print suspension letters for EDI claims from the FPPS system."
10 S DIR("?",2)=" Enter NON-EDI to just print suspension letters for claims that are not EDI."
11 S DIR("?",3)=" Enter ALL to print suspension letters for both EDI and NON-EDI claims."
12 S DIR("?")=" "
13 D ^DIR K DIR G END:$D(DIRUT)
14 S FBENA=Y
15 S VAR="BEGDATE^ENDDATE^FBSLW",VAL=BEGDATE_"^"_ENDDATE_"^"_FBSLW
16 I $G(DFN) S VAR="DFN^"_VAR,VAL=DFN_"^"_VAL
17 I $G(IFN) S VAR="IFN^"_VAR,VAL=IFN_"^"_VAL
18 I $G(FBDEN) S VAR="FBDEN^"_VAR,VAL=FBDEN_"^"_VAL
19 I $G(FBENA) S VAR="FBENA^"_VAR,VAL=FBENA_"^"_VAL
20 S K=0 F J=1:1:FBCTR S K=$O(FBPRG(K)) S VAR=VAR_"^FBPRG("""_K_""")",VAL=VAL_"^"_+FBPRG(K)
21 I $D(FBAAS) F J=0:0 S J=$O(FBAAS(J)) Q:J'>0 S VAR=VAR_"^FBAAS("_J_")",VAL=VAL_"^"
22 S PGM="START^FBAASLP",IOP="Q" D ZIS^FBAAUTL G:FBPOP END
23START K ^UTILITY($J),^TMP($J) U IO S UL="",$P(UL,"=",80)="=",FBPG=1
24 I $G(FBPRG("O")) S FBLET=+FBPRG("O") F K=0:0 S K=$O(^FBAAC("AI",K)) Q:K'>0 I $S($G(IFN):IFN=K,1:1) D STRT
25 I $G(FBPRG("P")),$D(^FBAA(162.1,"AG")) S FBLET=+FBPRG("P") D ^FBAASL1 K ^TMP($J)
26 I $G(FBPRG("C")),$D(^FBAA(162.2,"AI")) S FBLET=+FBPRG("C") D ^FBCHSLP
27 I $G(FBPRG("I")),$D(^FBAAI("AI")) S FBLET=+FBPRG("I") D ^FBCHSL1
28 I '$G(FBGOT) W !,"There are no suspension letters found that meet the criteria you have",!,"specified."
29END K FBAAS,UL,X,J,K,L,M,VNAM,VST1,VST2,VCITY,VSTATE,FBDT,FBA,VZIP,PNAME,A1,A2,CPT,FBDOS,FBRR,FBXX,DIC,DIWL,DIWF,BEGDATE,ENDDATE,FBAA,FBDRUG,FBFORM,FBI,FBLET,FBPDT,FBRX,FBSLW,FBSW,I,PGM,VAL,VAR,Z,ZZ,FBAAPGM,Y,PSSN,DIRUT
30 K FBAAOUT,FBCTR,FBPRG,FBY,FBMOD,FBMODLE,DFN,IFN,FBDEN,FBGOT,FBENA
31 K ^UTILITY($J),^TMP($J)
32 D CLOSE^FBAAUTL Q
33MORE F J=0:0 S J=$O(^FBAAC("AI",K,FBDT,J)) Q:J'>0 I $S($G(DFN):DFN=J,1:1) D:$D(^DPT(J,0)) GOTP I $D(^FBAAV(K,0)) D MID
34 Q
35GOTV S Y(0)=^FBAAV(K,0),VNAM=$P(Y(0),"^",1),FBSW=0
36 I VNAM["," S VNAM=$P(VNAM,",",2)_" "_$P(VNAM,",",1)
37 S VST1=$P(Y(0),"^",3),VST2=$P(Y(0),"^",14),VCITY=$P(Y(0),"^",4),VSTATE=$S($D(^DIC(5,+$P(Y(0),"^",5),0)):$P(^(0),"^",2),1:" "),VZIP=$P(Y(0),"^",6) S Y=DT D PDATE^FBAAUTL
38 W:'$G(FBPG) @IOF K:$G(FBPG) FBPG W:(IOSL)>70 !!!! W !!!!!!!!!!!,?5,VNAM,?60,FBPDT,!,?5,VST1,! I VST2]"" W ?5,VST2,!
39 W ?5,VCITY," ",VSTATE," ",VZIP,!!!!
40WPBEG S DIWL=1,DIWF="WC79" K ^UTILITY($J,"W")
41 I $D(^FBAA(161.3,FBLET,1,1)) F FBRR=0:0 S FBRR=$O(^FBAA(161.3,FBLET,1,FBRR)) Q:FBRR'>0 S FBXX=^(FBRR,0),X=FBXX D ^DIWP
42 D ^DIWW:$D(FBXX) K FBXX
43 Q
44MID S FBA=0 F FBAA=0:0 S FBA=$O(^FBAAC("AI",K,FBDT,J,FBA)) Q:FBA="" I $S(FBSLW=0:1,FBSLW=1&($D(FBAAS(FBA))):1,1:0) D MORE2
45 Q
46MORE2 F L=0:0 S L=$O(^FBAAC("AI",K,FBDT,J,FBA,L)) Q:L'>0 F M=0:0 S M=$O(^FBAAC("AI",K,FBDT,J,FBA,L,M)) Q:M'>0 I $D(^FBAAC(J,1,K,1,L,1,M,0)) S Z(0)=^(0) D:$P(Z(0),"^",20)'="R" BOT
47 Q
48WPBOT D ACT:$D(FBACRR) K FBACRR
49 S DIWL=1,DIWF="WC79" K ^UTILITY($J,"W") W !!
50 I $D(^FBAA(161.3,FBLET,2)) F FBRR=0:0 S FBRR=$O(^FBAA(161.3,FBLET,2,FBRR)) Q:FBRR'>0 S FBXX=^(FBRR,0),X=FBXX D ^DIWP
51 D ^DIWW:$D(FBXX) K FBXX
52 Q
53BOT Q:$S($G(FBDEN):$P(Z(0),U,3)>0,1:0)
54 N FBY3,FBFPPSC
55 S FBY3=$G(^FBAAC(J,1,K,1,L,1,M,3))
56 S FBFPPSC=$P(FBY3,U)
57 Q:$S(FBENA=2&(FBFPPSC]""):1,FBENA=1&(FBFPPSC=""):1,1:0)
58 N FBY,FBX,T,TAMT,FBAC,FBJ,FBCSID,FBUNITS,FBADJLR,FBADJLA,FBRRMKL,FBFPPSL
59 I FBSW=1 D GOTV,HED S FBSW=0,FBGOT=1
60 S FBDOS=$S($D(^FBAAC(J,1,K,1,L,0)):$P(^(0),"^",1),1:"")
61 S CPT=$P(Z(0),"^",1),A1=$P(Z(0),"^",2)+.0001,A2=$P(Z(0),"^",3)+.0001,A1=$P(A1,".",1)_"."_$E($P(A1,".",2),1,2),A2=$P(A2,".",1)_"."_$E($P(A2,".",2),1,2)
62 I CPT]"" S CPT=$$CPT^FBAAUTL4(CPT)
63 S T=$P(Z(0),U,5)
64 I T]"" S T=$P($G(^FBAA(161.27,+T,0)),U)
65 S TAMT=$FN($P(Z(0),U,4),"",2)
66 S FBX=$$ADJLRA^FBAAFA(M_","_L_","_K_","_J_",")
67 S FBY=$G(^FBAAC(J,1,K,1,L,1,M,2))
68 S FBFPPSL=$P(FBY3,U,2)
69 S FBCSID=$P(FBY,U,16)
70 S FBUNITS=$P(FBY,U,14)
71 S FBADJLR=$P(FBX,U)
72 F FBJ=1:1 S FBAC=$P(FBADJLR,",",FBJ) Q:FBAC="" S FBACRR(FBAC)=""
73 S FBADJLA=$P(FBX,U,2)
74 S FBRRMKL=$$RRL^FBAAFR(M_","_L_","_K_","_J_",")
75 S FBMODLE=$$MODL^FBAAUTL4("^FBAAC("_J_",1,"_K_",1,"_L_",1,"_M_",""M"")","E")
76 I $Y+4>IOSL W @IOF D HED
77 W !!,$E(PNAME,1,26),?33,PSSN,?49,FBCSID
78 W !,$$DATX^FBAAUTL(FBDOS),?10,CPT_$S($G(FBMODLE)]"":"-"_$P(FBMODLE,","),1:""),?33,FBUNITS
79 I $P($G(FBMODLE),",",2)]"" D
80 . N FBI
81 . F FBI=2:1 S FBMOD=$P(FBMODLE,",",FBI) Q:FBMOD="" D
82 . . I $Y+4>IOSL W @IOF D HED W !," (continued)"
83 . . W !,?15,"-",FBMOD
84 W !,?10,$J(A1,6),?24,$J(A2,6)
85 ; write adjustment reasons, if null then write suspend code
86 W ?35,$S(FBADJLR]"":FBADJLR,1:T)
87 ; write adjustment amounts, if null then write amount suspended
88 W ?49,$S(FBADJLA]"":FBADJLA,1:TAMT)
89 W ?66,FBRRMKL
90 I FBFPPSC]"" W !,?10,"FPPS Claim ID: ",FBFPPSC,?38,"FPPS Line Item: ",FBFPPSL
91 W !
92 I FBADJLR="" G:FBA=4&($D(^FBAAC(J,1,K,1,L,1,M,1))) WPFT D
93 . S DIWL=1,DIWF="WC79",FBI=FBA K ^UTILITY($J,"W")
94 . F FBRR=0:0 S FBRR=$O(^FBAA(161.27,FBI,1,FBRR)) Q:FBRR'>0 S FBXX=^(FBRR,0),X=FBXX D ^DIWP
95 . D ^DIWW:$D(FBXX) K FBXX
96 Q
97ACT ; print table of adjustment reason descriptions
98 ; Input
99 ; FBACRR( - required, array
100 ; FBACRR(FBADJRE)=""
101 ; where FBADJRE = adjustment reason code, external value
102 N FBADJRE,FBI,FBACT
103 W !,"*Adjustment Code Text:"
104 S FBADJRE="" F S FBADJRE=$O(FBACRR(FBADJRE)) Q:FBADJRE="" D
105 . ; get description of code in FBACT
106 . I $$AR^FBUTL1(,FBADJRE,FBSCDT,"FBACT")<0 Q ; quit if error
107 . ; print code and description
108 . K ^UTILITY($J,"W")
109 . S DIWL=1,DIWF="WC79"
110 . ; include code in output
111 . S X=$$LJ^XLFSTR("("_FBADJRE_")",7," ") D ^DIWP
112 . S DIWF="WC79I7"
113 . ; include description in output
114 . S FBI=0 F S FBI=$O(FBACT(FBI)) Q:FBI="" S X=FBACT(FBI) I X]"" D ^DIWP
115 . D ^DIWW
116 Q
117 ;
118HED W !,"PATIENT NAME",?33,"SSN",?49,"PATIENT ACCOUNT NUMBER"
119 W !,"SVC DATE",?10,"CPT-MOD",?33,"UNITS"
120 W !,?10,"AMT CLAIMED",?24,"AMT PAID",?35,"ADJ CODE",?49,"ADJ AMT",?66,"REMIT REMARKS"
121 W !,UL Q
122 ;
123GOTP ; Utilize new API for Name Standardization
124 ;
125 S Y(0)=^DPT(J,0),PNAME=$P(Y(0),"^",1),PSSN=$TR($$SSNL4^FBAAUTL($$SSN^FBAAUTL(J)),"-","")
126 I PNAME["," D
127 .N FBNAMES
128 .S FBNAMES("FILE")=2,FBNAMES("IENS")=J_",",FBNAMES("FIELD")=.01
129 .S PNAME=$$NAMEFMT^XLFNAME(.FBNAMES)
130 Q
131SEL W !! S DIC="^FBAA(161.27,",DIC(0)="AEQM" D ^DIC G ENDSL:X=""!(X="^"),SEL:Y<0 S DA=+Y,FBAAS(DA)="",FBSLW=1 G SEL
132ENDSL I '$D(FBAAS) W !!,*7,"No suspension codes selected!" G END
133 G AHEAD
134PSEL F FBA=0:0 S FBA=$O(FBAAS(FBA)) Q:FBA'>0 I $D(^FBAAC("AI",FBA)) F FBDT=BEGDATE-.001:0 S FBDT=$O(^FBAAC("AI",FBA,FBDT)) Q:FBDT'>0!(FBDT>ENDDATE) D MORE
135 G END
136WPFT S DIWL=1,DIWF="WC79" K ^UTILITY($J,"W")
137 F FBRR=0:0 S FBRR=$O(^FBAAC(J,1,K,1,L,1,M,1,FBRR)) Q:FBRR'>0 S FBXX=^(FBRR,0),X=FBXX D ^DIWP
138 D ^DIWW:$D(FBXX) K FBXX
139 Q
140STRT N FBACRR,FBSCDT S FBSW=1 S Z=$O(^FBAAC("AI",K,BEGDATE-.001)) S FBDT=BEGDATE-.001 F ZZ=0:0 S FBDT=$O(^FBAAC("AI",K,FBDT)) D WPBOT:FBDT'>0&(FBSW=0)!(FBDT>ENDDATE)&(FBSW=0) Q:FBDT'>0!(FBDT>ENDDATE) S FBSCDT=FBDT D MORE
141 Q
Note: See TracBrowser for help on using the repository browser.