source: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBCHEAP.m@ 1556

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

initial load of WorldVistAEHR

File size: 3.4 KB
Line 
1FBCHEAP ;AISC/DMK-ENTER AMOUNT PAID FROM PRICER ;7/8/2003
2 ;;3.5;FEE BASIS;**38,55,61,77**;JAN 30, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4DIC W ! S DIC="^FBAA(161.7,",DIC(0)="AEQMZ",DIC("S")="I $P(^(0),U,15)=""Y""&($G(^(""ST""))=""P"")"_$S($D(^XUSEC("FBAASUPERVISOR",DUZ)):"",1:"&($P(^(0),U,5)=DUZ)") D ^DIC
5 G END:X="^"!(X=""),DIC:Y<0 S FBN=+Y,FBN(0)=Y(0)
6ASK S DIR(0)="Y",DIR("A")="Would you like to reject any invoices from the pricer",DIR("B")="NO" D ^DIR K DIR G END:$D(DIRUT),REJECT:Y
7DIC1 W !! S DIC="^FBAAI(",DIC(0)="AEQMZ",DIC("A")="Select Patient: ",D="D",DIC("S")="I $P(^(0),U,17)=FBN",DIC("W")="W ?25,$S($D(^DPT($P(^(0),U,4),0)):$P(^(0),U),1:"""")" D ^DIC S DIE=DIC K DIC,D G END:X="^",DIC:X=""!(Y<0)
8 S (DA,FBI)=+Y,FBI(0)=Y(0) G END:'$D(^FBAAI(FBI,0))
9DISP S FBLISTC="" D HOME^%ZIS,START^FBCHDI2
10 W !! S FBJ=$P(FBI(0),"^",8)
11 ; set FB1725 flag = true if payment for a 38 U.S.C. 1725 claim
12 S FB1725=$S($P(FBI(0),U,5)["FB583":+$P($G(^FB583(+$P(FBI(0),U,5),0)),U,28),1:0)
13 S DR="26;S FBPAMT=X;W:FB1725 !?2,""**Payment is for emergency treatment under 38 U.S.C. 1725."";W:FB1725&($G(FBPAMT)>0) !?2,"" 70% of Pricer Amount = ""_$J(.7*FBPAMT,0,2);8;S FBK=X"
14 ;S DR(1,162.5,1)="S:(FBJ-FBK)'>0 Y=24;9//^S X=$S(FBJ-FBK:FBJ-FBK,1:"""");S:'X Y=24;10;S:X'=4 Y=24;18"
15 S DR(1,162.5,1)="S FBX=$$ADJ^FBUTL2(FBJ-FBK,.FBADJ,1,,,1)"
16 S DR(1,162.5,2)="@20;24R;S:$$INPICD^FBCSV1(X,$G(DA),$P($G(FBIN),""^"",6)) Y=""@20"";24.5R"
17 S DR(1,162.5,3)="S FBX=$$RR^FBUTL4(.FBRRMK,2)"
18 S DIE("NO^")=""
19 D
20 . N ICDVDT S ICDVDT=$P($G(FBIN),"^",6) D ^DIE
21 K DIE("NO^") G END:$D(DTOUT)
22 ; file adjustment reasons
23 D FILEADJ^FBCHFA(FBI_",",.FBADJ)
24 ; file remittance remarks
25 D FILERR^FBCHFR(FBI_",",.FBRRMK)
26 D TOT S $P(FBN(0),"^",9)=FBK(1),^FBAA(161.7,FBN,0)=FBN(0)
27 D CHK I $D(FBCHSW) K FBCHSW G DIC1
28 I '$D(FBCHSW) S DA=FBN,(DIC,DIE)="^FBAA(161.7,",DIC(0)="LQ",DR="11////^S X=""A""",DLAYGO=161.7 D ^DIE G DIC
29 G DIC1:$O(^FBAAI("AC",FBN,FBI))
30END K DA,DFN,DIC,DIE,DR,FBAAOUT,FBDX,FBI,FBIN,FBJ,FBK,FBLISTC,FBN,FBPROC,FBVEN,FBVID,I,J,K,L,POP,Q,VA,VADM,X,POP,YS,VAL,ZZ,Y,FBRR,FBTYPE,FBCHSW,DIRUT,FB1725,FBPAMT
31 K FBADJ,FBRRMK
32 D END^FBCHDI
33 Q
34REJECT S FBTYPE="B9"
35 W ! S DIC="^FBAAI(",DIC(0)="AEQMZ",DIC("S")="I $P(^(0),U,17)=FBN&($P(^(0),U,9)="""")",DIC("W")="W ?25,$S($D(^DPT($P(^(0),U,4),0)):$P(^(0),U),1:"""")" D ^DIC G END:X=""!(X="^"),REJECT:Y<0 S FBI=+Y,FBI(0)=Y(0)
36 S FBLISTC="" D HOME^%ZIS,START^FBCHDI2
37RASK S DIR(0)="F^2:40",DIR("A")="Enter reason for rejecting (2-40 characters)",DIR("?")="Enter a reason for rejecting payment from Austin Pricer" D ^DIR K DIR G END:$D(DIRUT) S FBRR=X
38ASKSU S DIR(0)="Y",DIR("A")="Are you sure you want to reject this item",DIR("B")="NO" D ^DIR K DIR G END:$D(DIRUT),DIC:'Y
39 S (DLAYGO,DIDEL)=162.5,DIC(0)="AEQLM"
40 S (DIC,DIE)="^FBAAI(",DA=FBI,DR="13////^S X=""P"";14////^S X=FBRR;15////^S X=FBN;20///^S X=""@""" D ^DIE
41 S $P(FBN(0),"^",10)=$P(FBN(0),"^",10)-1,$P(FBN(0),"^",11)=$P(FBN(0),"^",11)-1,$P(FBN(0),"^",17)="Y",^FBAA(161.7,FBN,0)=FBN(0)
42RASKSU I $O(^FBAAI("AC",FBN,FBI)) S DIR(0)="Y",DIR("A")="Reject another",DIR("B")="NO" D ^DIR K DIR G END:$D(DIRUT),REJECT:Y
43 I $P(^FBAA(161.7,FBN,0),"^",11)=0 S (DIC,DIE)="^FBAA(161.7,",DIC(0)="AEQM",DA=FBN,DR="11////^S X=""V"";12////^S X=DT" D ^DIE G DIC
44 G END
45CHK F I=0:0 S I=$O(^FBAAI("AC",FBN,I)) Q:I'>0 I $D(^FBAAI(I,0)),$P(^(0),"^",9)="" S FBCHSW=1
46 Q
47TOT S FBK(1)=0 F I=0:0 S I=$O(^FBAAI("AC",FBN,I)) Q:'I S FBK(1)=FBK(1)+$P($G(^FBAAI(I,0)),"^",9)
48 Q
Note: See TracBrowser for help on using the repository browser.