source: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAACCB.m@ 1495

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

initial load of WorldVistAEHR
File size: 5.1 KB
Line 
1FBAACCB ;AISC/GRR-CLERK CLOSE BATCH ;8/7/2003
2 ;;3.5;FEE BASIS;**4,61,77**;JAN 30, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 K QQ D DT^DICRW
5BT W !! S DIC="^FBAA(161.7,",DIC(0)="AEQ",DIC("S")=$S($D(^XUSEC("FBAASUPERVISOR",DUZ)):"I $G(^(""ST""))=""O""",1:"I $P(^(0),U,5)=DUZ&($G(^(""ST""))=""O"")") D ^DIC K DIC("S")
6 G Q^FBAACCB0:X="^"!(X=""),BT:Y<0 S B=+Y,FZ=^FBAA(161.7,B,0),FBTYPE=$P(FZ,"^",3)
7 I FBTYPE="B3",'$D(^FBAAC("AC",B)) W !!,*7,"No payments in Batch yet!",! G BT
8 I FBTYPE="B2",'$D(^FBAAC("AD",B)) W !!,*7,"No Payments in Batch yet!",! G BT
9 I FBTYPE="B5",'$D(^FBAA(162.1,"AE",B)) W !!,*7,"No Payments in Batch yet!",! G BT
10 I FBTYPE="B9",'$D(^FBAAI("AC",B)) W !!,*7,"No Payments in Batch yet!",! G BT
11RDD S DIR(0)="Y",DIR("A")="Want to review batch",DIR("B")="NO",DIR("?")="If you want a detail list of each payment line, answer ""Yes"" otherwise press Return key" D ^DIR K DIR
12 G BT:$D(DIRUT) W:Y @IOF D:Y LIST:FBTYPE="B3",LISTP:FBTYPE="B5",LISTT^FBAACCB0:FBTYPE="B2",LISTC^FBAACCB1:FBTYPE="B9"
13RDD1 S DIR(0)="Y",DIR("A")="Do you still want to close Batch",DIR("B")="YES" D ^DIR K DIR G BT:'Y!$D(DIRUT)
14 S C=0,T=0 G PHARM^FBAACCB1:FBTYPE="B5",TRAV^FBAACCB1:FBTYPE="B2",CHNH^FBAACCB1:FBTYPE="B9"
15 F J=0:0 S J=$O(^FBAAC("AC",B,J)) Q:J'>0 F K=0:0 S K=$O(^FBAAC("AC",B,J,K)) Q:K'>0 F L=0:0 S L=$O(^FBAAC("AC",B,J,K,L)) Q:L'>0 F M=0:0 S M=$O(^FBAAC("AC",B,J,K,L,M)) Q:M'>0 D GOT
16FIN S $P(FZ,"^",9)=T,$P(FZ,"^",11)=C
17 S $P(FZ,"^",13)=DT,^FBAA(161.7,B,0)=FZ,^FBAA(161.7,B,"ST")="C",^FBAA(161.7,"AC","C",B)="",DA=B,DR="0;ST" K ^FBAA(161.7,"AC","O",B),^FBAA(161.7,"AB","O",$P(^FBAA(161.7,B,0),"^",5),B) W !! D EN^DIQ W !!,"Batch Closed" G BT
18GOT S Y(0)=$G(^FBAAC(J,1,K,1,L,1,M,0)),FBIN=$P(Y(0),"^",16)
19 I $P(Y(0),"^",3)>0 S T=T+$P(Y(0),"^",3),C=C+1
20 Q
21LIST S Q="",$P(Q,"=",80)="="
22 S IOP=$S($D(ION):ION,1:"HOME") D ^%ZIS K IOP
23ENM D HED S (FBIN,FBINOLD)="",(FBAAOUT,FBINTOT)=0 F XY=0:0 S FBIN=$O(^FBAAC("AJ",B,FBIN)) Q:FBIN=""!($G(FBAAOUT)) D INTOT^FBAACCB0 F J=0:0 S J=$O(^FBAAC("AJ",B,FBIN,J)) Q:J'>0!($G(FBAAOUT)) D GMORE^FBAACCB0
24 I '$G(FBAAOUT) S FBIN=0 D INTOT^FBAACCB0
25 Q
26SET ;
27 N FBADJLA,FBADJLR,FBFPPSC,FBFPPSL,FBX,FBY3,TAMT
28 S N=$S($D(^DPT(J,0)):$P(^DPT(J,0),"^",1),1:""),S=$S(N]"":$P(^DPT(J,0),"^",9),1:""),V=$S($D(^FBAAV(K,0)):$P(^FBAAV(K,0),"^",1),1:""),VID=$S(V]"":$P(^(0),"^",2),1:"")
29 S D=+$G(^FBAAC(J,1,K,1,L,0)) Q:'D
30 S Y=$G(^FBAAC(J,1,K,1,L,1,M,0)) Q:Y']""
31 S FBY3=$G(^FBAAC(J,1,K,1,L,1,M,3))
32 S FBFPPSC=$P(FBY3,U)
33 S FBFPPSL=$P(FBY3,U,2)
34 S FBX=$$ADJLRA^FBAAFA(M_","_L_","_K_","_J_",")
35 S FBADJLR=$P(FBX,U)
36 S FBADJLA=$P(FBX,U,2)
37 S T=$P(Y,"^",5),FBIN=$P(Y,"^",16),ZS=$P(Y,"^",20)
38 S TAMT=$FN($P(Y,"^",4),"",2)
39 S FBVP=$S($P(Y,"^",21)="VP":"#",1:"")
40 S FBAACPT=$$CPT^FBAAUTL4($P(Y,U))
41 S CPTDESC=$$CPT^FBAAUTL4($P(Y,U),1,D)
42 S FBVCHDT=$P(Y,"^",6),FBIN(1)=$P(Y,"^",15) D FBCKO^FBAACCB2(J,K,L,M)
43 S FBMODLE=$$MODL^FBAAUTL4("^FBAAC("_J_",1,"_K_",1,"_L_",1,"_M_",""M"")","E")
44GO S A1=$P(Y,"^",2)+.0001,A2=$P(Y,"^",3)+.0001,A1=$P(A1,".",1)_"."_$E($P(A1,".",2),1,2),A2=$P(A2,".",1)_"."_$E($P(A2,".",2),1,2),FBINTOT=FBINTOT+A2
45 D WRT:FBTYPE'="B2",WRTT^FBAACCB0:FBTYPE="B2"
46 Q
47WRT I $Y+8>IOSL D ASKH^FBAACCB0:$E(IOST,1,2)["C-" Q:FBAAOUT W @IOF D HED
48 S B(1617)=$S(B="":"",$D(^FBAA(161.7,B,0)):$P(^(0),"^"),1:"")
49 W !!,N,?35,$$SSN^FBAAUTL(J),?58,B(1617),?67,$$DATX^FBAAUTL($G(FBVCHDT)),!,?3,V,?42,VID,?55,FBIN,?67,$$DATX^FBAAUTL(FBIN(1))
50 W !,$S($D(QQ):QQ_")",1:""),$S(ZS="R":"*",1:""),$S(FBTYPE="B3":FBVP,1:""),$S(FBTYPE="B5":FBPV,1:""),$S($G(FBCAN)]"":"+",1:"")
51 I FBTYPE="B3" W ?4,$$DATX^FBAAUTL(D),?14,FBAACPT_$S($G(FBMODLE)]"":"-"_$P(FBMODLE,","),1:""),?24,CPTDESC,?54,FBFPPSC,?66,FBFPPSL
52 I FBTYPE="B5" W ?4,$$DATX^FBAAUTL(D),?14,FBAACPT_$S($G(FBMODLE)]"":"-"_$P(FBMODLE,","),1:""),?24,CPTDESC,?56,FBFPPSC,?68,FBFPPSL
53 I $P($G(FBMODLE),",",2)]"" D Q:FBAAOUT
54 . N FBI,FBMOD
55 . F FBI=2:1 S FBMOD=$P(FBMODLE,",",FBI) Q:FBMOD="" D Q:FBAAOUT
56 . . I $Y+5>IOSL D Q:FBAAOUT
57 . . . I $E(IOST,1,2)="C-" D ASKH^FBAACCB0 Q:FBAAOUT
58 . . . W @IOF D HED W !,"(continued)"
59 . . W !,?19,"-",FBMOD
60 W !?4,$J(A1,6),?17,$J(A2,6)
61 ; write adjustment reasons, if null then write suspend code
62 W ?30,$S(FBADJLR]"":FBADJLR,1:T)
63 ; write adjustment amounts, if null then write amount suspended
64 W ?41,$S(FBADJLA]"":FBADJLA,1:TAMT)
65 D PMNT^FBAACCB2 S FBINOLD=FBIN
66 Q
67HED W "Patient Name",?20,"('*' Reimbursement to Patient '+' Cancellation Activity)",!,?13,"('#' Voided Payment)",?58,"Batch #",?67,"Voucher Date"
68 W !,?3,"Vendor Name",?42,"Vendor ID",?53,"Invoice #",?67,"Date Rec'd."
69 I FBTYPE="B3" D
70 . W !,?4,"SVC DATE",?14,"CPT-MOD",?24,"SERVICE PROVIDED",?54,"FPPS CLAIM",?66,"FPPS LINE"
71 . W !,?4,"CLAIMED",?17,"PAID",?30,"ADJ CODE",?41,"ADJ AMOUNT"
72 I FBTYPE="B5" D
73 . W !,?4,"RX DATE",?14,"RX #",?24,"DRUG NAME",?56,"FPPS CLAIM",?68,"FPPS LINE"
74 . W !,?4,"CLAIMED",?17,"PAID",?30,"ADJ CODE",?41,"ADJ AMOUNT"
75 W !,Q,!
76 Q
77LISTP S Q="",$P(Q,"=",80)="="
78 S IOP=$S($D(ION):ION,1:"HOME") D ^%ZIS K IOP
79ENP D HED S (FBAAOUT,FBINTOT)=0,FBINOLD=""
80 F A=0:0 S A=$O(^FBAA(162.1,"AE",B,A)) Q:A'>0!($G(FBAAOUT)) S FBIN=A D SETV^FBAACCB0 F B2=0:0 S B2=$O(^FBAA(162.1,"AE",B,A,B2)) Q:B2'>0!($G(FBAAOUT)) D INTOT^FBAACCB0 I $D(^FBAA(162.1,A,"RX",B2,0)) S Z(0)=^(0) D MORE^FBAACCB1
81 I '$G(FBAAOUT) S FBIN=0 D INTOT^FBAACCB0
82 Q
Note: See TracBrowser for help on using the repository browser.