source: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAAPET.m@ 702

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

initial load of WorldVistAEHR
File size: 6.0 KB
RevLine 
[613]1FBAAPET ;AISC/DMK-EDIT PAYMENT ;7/13/2003
2 ;;3.5;FEE BASIS;**4,38,55,61,77**;JAN 30, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 S FBOT=1
5GETPT I $G(BAT) D
6 .I '$D(^FBAAC("AC",+BAT)) F I=9,10,11 S $P(^FBAA(161.7,+BAT,0),U,I)=""
7 .I $D(^FBAAC("AC",+BAT)) D S $P(^FBAA(161.7,+BAT,0),U,11)=I,$P(^(0),U,9)=$G(FBTOT) K I,FBTOT
8 ..N J,K,L,M S (I,J,K,L,M,FBTOT)=0
9 ..F S J=$O(^FBAAC("AC",+BAT,J)) Q:'J F S K=$O(^FBAAC("AC",+BAT,J,K)) Q:'K F S L=$O(^FBAAC("AC",+BAT,J,K,L)) Q:'L F S M=$O(^FBAAC("AC",+BAT,J,K,L,M)) Q:'M I $D(^FBAAC(J,1,K,1,L,1,M,0)) S I=I+1,FBTOT=FBTOT+$P(^(0),U,3)
10 W !! S DIC="^FBAAC(",DIC(0)="AEQM" D ^DIC G END:X="^"!(X=""),GETPT:Y<0 S (DFN,FBDA(3))=+Y
11 S:'$D(^FBAAC(DFN,1,0)) ^FBAAC(DFN,1,0)="^162.01P^0^0"
12 S DIC=DIC_DFN_",1,"
13GETVD W !! S DIC(0)="AEQM" D ^DIC G GETPT:X="^"!(X=""),GETVD:Y<0 S (FBV,FBVD,FBDA(2))=+Y
14 S:'$D(^FBAAC(DFN,1,FBDA(2),1,0)) ^FBAAC(DFN,1,FBDA(2),1,0)="^162.02DA^0^0"
15 S DIC=DIC_FBVD_",1,"
16GETDT S DIC(0)="AEQM",DIC("A")="Date of Service: " D ^DIC K DIC("A") G GETPT:X="^"!(X=""),GETDT:Y<0 S (FBSD,FBSDI,FBDA(1))=+Y,FBAADT=$P(Y,U,2)
17 S:'$D(^FBAAC(DFN,1,FBDA(2),1,FBDA(1),1,0)) ^FBAAC(DFN,1,FBDA(2),1,FBDA(1),1,0)="^162.03A^0^0"
18 S FBZ=DIC_FBSD_",1,"
19SERV S DA(3)=FBDA(3),DA(2)=FBDA(2),DA(1)=FBDA(1)
20 S DIC("W")="N FBX S FBX=$$MODL^FBAAUTL4(""^FBAAC(FBDA(3),1,FBDA(2),1,FBDA(1),1,+Y,""""M"""")"",""E"") W:FBX]"""" "" CPT Modifier(s): "",FBX Q"
21 S DIC=FBZ,DIC(0)="AEQMZ"
22 D
23 . N ICPTVDT S ICPTVDT=$G(FBAADT) D ^DIC
24 G GETPT:X="^"!(X=""),SERV:Y<0 S (FBSV,FBAACPI,FBDA)=+Y,BAT=$P(Y(0),U,8),FBDUZ=$P(Y(0),U,7),(FBAACP,FBAACP(0))=$P(Y,U,2),K=$P(Y(0),U,3),FBAAPTC=$P(Y(0),U,20),J(0)=$P(Y(0),U,2)
25 ; set FB1725 true (1) if payment is for a Mill Bill claim
26 S FB1725=$S($P(Y(0),U,13)["FB583":+$P($G(^FB583(+$P(Y(0),U,13),0)),U,28),1:0)
27 I FBDUZ'=DUZ&('$D(^XUSEC("FBAASUPERVISOR",DUZ))) W !!,*7,"Sorry,only the clerk who entered the payment ",!," or a supervisor can edit this payment." G GETPT
28 S FBAAMM1=$P($G(^FBAAC(FBDA(3),1,FBDA(2),1,FBDA(1),1,FBDA,2)),U,2)
29 S FBFSAMT(0)=$P($G(^FBAAC(FBDA(3),1,FBDA(2),1,FBDA(1),1,FBDA,2)),U,12)
30 ; determine lesser of original fee schedule amount and amount claimed
31 S FBAMTPD(0)=$S(FBFSAMT(0)="":J(0),FBFSAMT(0)>J(0):J(0),1:FBFSAMT(0))
32 S FBMODL=$$MODL^FBAAUTL4("^FBAAC("_FBDA(3)_",1,"_FBDA(2)_",1,"_FBDA(1)_",1,"_FBDA_",""M"")")
33 ; load current adjustment data
34 D LOADADJ^FBAAFA(FBDA_","_FBDA(1)_","_FBDA(2)_","_FBDA(3)_",",.FBADJ)
35 ; save adjustment data prior to edit session in sorted list
36 S FBADJL(0)=$$ADJL^FBUTL2(.FBADJ) ; sorted list of original adjustments
37 ; load current remittance remark data
38 D LOADRR^FBAAFR(FBDA_","_FBDA(1)_","_FBDA(2)_","_FBDA(3)_",",.FBRRMK)
39 ; save remittance remarks prior to edit session in sorted list
40 S FBRRMKL(0)=$$RRL^FBUTL4(.FBRRMK)
41 ; save FPPS data prior to edit session
42 S FBFPPSC(0)=$P($G(^FBAAC(FBDA(3),1,FBDA(2),1,FBDA(1),1,FBDA,3)),U)
43 S FBFPPSC=FBFPPSC(0)
44 S FBFPPSL(0)=$P($G(^FBAAC(FBDA(3),1,FBDA(2),1,FBDA(1),1,FBDA,3)),U,2)
45 S FBFPPSL=FBFPPSL(0)
46 G:BAT']"" EDIT
47 I $G(^FBAA(161.7,BAT,"ST"))]"",$P(^FBAA(161.7,BAT,"ST"),"^")="S"!($P(^FBAA(161.7,BAT,"ST"),"^")="T")&('$D(^XUSEC("FBAASUPERVISOR",DUZ))) W !!,*7,"Sorry, only the Supervisor can edit a payment once the batch has been released." G GETPT
48 I $G(^FBAA(161.7,BAT,"ST"))]"",$P(^FBAA(161.7,BAT,"ST"),"^")="V" W !!,*7,"Sorry,you cannot edit a payment once the batch has been Finalized." G GETPT
49EDIT S DA=FBSV
50 ;
51 ; first edit CPT code and modifiers
52 D CPTM^FBAALU(FBAADT,DFN,FBAACP(0),FBMODL) I '$G(FBGOT) G GETPT
53 ; if CPT was changed then update file
54 I FBAACP'=FBAACP(0) D I FBAACP="@" G GETPT
55 . N FBIENS,FBFDA
56 . S FBIENS=FBDA_","_FBDA(1)_","_FBDA(2)_","_FBDA(3)_","
57 . S FBFDA(162.03,FBIENS,.01)=FBAACP
58 . D FILE^DIE("","FBFDA") D MSG^DIALOG()
59 ; if modifiers changed then update file
60 I FBMODL'=$$MODL^FBAAUTL4("FBMODA") D REPMOD^FBAAUTL4(FBDA(3),FBDA(2),FBDA(1),FBDA)
61 ;
62 ; now edit remaining fields
63 S DIE("NO^")=""
64 S DR="48;47;S FBUNITS=X;42R;S FBZIP=X;S:$$ANES^FBAAFS($$CPT^FBAAUTL4(FBAACP)) Y=""@2"";43///@;S FBTIME=X;S Y=""@3"";@2;43R;S FBTIME=X;@3"
65 S DR(1,162.03,1)="S FBAAMM=$S(FBAAPTC=""R"":"""",1:1);D PPT^FBAACO1(FBAAMM1);34///@;34////^S X=FBAAMM1;30R;S FBHCFA(30)=X;1;S J=X;Q"
66 S DR(1,162.03,2)="D FEEDT^FBAACO3;44///@;44///^S X=FBFSAMT;45///@;45///^S X=FBFSUSD;S:FBAMTPD'>0!(FBAMTPD=FBAMTPD(0)) Y=""@4"";2///^S X=FBAMTPD;@4;2//^S X=FBAMTPD;D CHKIT^FBAACO3;S K=X"
67 ;S DR(1,162.03,3)="3////^S X=$S(J-K:J-K,1:"""");I X S Y=""@11"";4////@;S Y=""@5"";@11;3R;4R;S:X'=4 Y=""@5"";22"
68 S DR(1,162.03,3)="K FBADJD;M FBADJD=FBADJ;S FBX=$$ADJ^FBUTL2(J-K,.FBADJ,2,,.FBADJD,1)"
69 S DR(1,162.03,4)="S FBX=$$FPPSC^FBUTL5(1,FBFPPSC);S:FBX=-1 Y=0;S:FBX="""" Y=""@5"";50///^S X=FBX;S FBFPPSC=X;S FBX=$$FPPSL^FBUTL5(FBFPPSL);S:FBX=-1 Y=0;51///^S X=FBX;S FBFPPCL=X;S Y=""@55"";@5;50///@;S FBFPPSC="""";51///@;S FBFPPSL="""";@55"
70 S DR(1,162.03,5)="K DIE(""NO^"");W !,""Exit ('^') allowed now"";26;S PRC(""SITE"")=X;8;13;Q;33;49"
71 S DR(1,162.03,6)="15;17;16;S:X=1 Y=""@1"";@6;28R;S:$$INPICD9^FBCSV1(X,"""",$G(FBAADT)) Y=""@6"";31;32R;S Y=""@7"";@1;28;I X]"""" S:$$INPICD9^FBCSV1(X,"""",$G(FBAADT)) Y=""@1"";31"
72 S DR(1,162.03,7)="@7;K FBRRMKD;M FBRRMKD=FBRRMK;S FBX=$$RR^FBUTL4(.FBRRMK,2,,.FBRRMKD)"
73 S DIE=FBZ
74 D
75 . N ICPTVDT,ICDVDT S (ICPTVDT,ICDVDT)=$G(FBAADT) D ^DIE
76 ; if adjustment data changed then file
77 I $$ADJL^FBUTL2(.FBADJ)'=FBADJL(0) D FILEADJ^FBAAFA(FBDA_","_FBDA(1)_","_FBDA(2)_","_FBDA(3)_",",.FBADJ)
78 ; if remit remark data changed then file
79 I $$RRL^FBUTL4(.FBRRMK)'=FBRRMKL(0) D FILERR^FBAAFR(FBDA_","_FBDA(1)_","_FBDA(2)_","_FBDA(3)_",",.FBRRMK)
80 ; if FPPS CLAIM ID changed, update other line items on invoice
81 I FBFPPSC'=FBFPPSC(0) D
82 . N FBAAIN
83 . S FBAAIN=$$GET1^DIQ(162.03,FBDA_","_FBDA(1)_","_FBDA(2)_","_FBDA(3)_",",14)
84 . D CKINVEDI^FBAAPET1(FBFPPSC(0),FBFPPSC,FBAAIN,FBDA_","_FBDA(1)_","_FBDA(2)_","_FBDA(3)_",")
85 K FBSV W !! G SERV
86END K DR,DIC,DIE,X,DFN,FBOT,FBVD,FBSD,BAT,FBAADT,FBSV,DA,FBDA,FBZ,FBDUZ,FBAACP,FBFY,FY,FBAMTPD,J,K,Y,ZZ,PRC,FBHOLDX,FBV,FBSDI,FBAACPI
87 K FBFSAMT,FBFSUSD,FBMODA,FBZIP,FBTIME,FBHCFA(30),FBAAPTC,FB1725,FBADJ,FBADJD,FBADJL(0),FBRRMK,FBRRMKD,FBRRMKL(0),FBX,FBUNITS
88 Q
Note: See TracBrowser for help on using the repository browser.