source: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAAVR1.m@ 767

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

initial load of WorldVistAEHR

File size: 3.6 KB
Line 
1FBAAVR1 ;AISC/GRR-FEE BASIS VOUCHER AUDIT DELETE AN ITEM ;10AUG86
2 ;;3.5;FEE BASIS;;JAN 30, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4DELT ;TRAVEL LINE ITEM REJECT
5 D GET Q:X="^"!(X="") I '$D(^FBAAC("AD",B,J)) W !!,*7,"No payments in this batch for that patient!" G DELT
6 S (QQ,FBAAOUT)=0 W @IOF D HEDP^FBAACCB0
7 F K=0:0 S K=$O(^FBAAC("AD",B,J,K)) Q:K'>0!(FBAAOUT) S QQ=QQ+1,QQ(QQ)=J_"^"_K S Y(0)=^FBAAC(J,3,K,0) D SETT^FBAACCB0
8RLT1 S DIR(0)="Y",DIR("A")="Reject all line items for this patient",DIR("B")="YES" D ^DIR K DIR G DELT:$D(DIRUT),LOOPT:Y
9RLT S DIR(0)="NO^1:"_QQ,DIR("A")="Reject which line item" D ^DIR K DIR G DELT:X=""!$D(DIRUT) S HX=X
10 I '$D(QQ(HX)) W !!,*7,"You just deleted that one!!" G RLT
11RASK S DIR(0)="Y",DIR("A")="Are you sure you want to reject line item number: "_HX,DIR("B")="NO" D ^DIR K DIR G RLT:$D(DIRUT)!'Y
12 S J=$P(QQ(HX),"^",1),K=$P(QQ(HX),"^",2),FBRFLAG=1,XMB(2)="some"
13RDR2 S DIR(0)="F^2:40",DIR("A")="Enter reason for rejecting" D ^DIR K DIR W:$D(DIRUT) !!,"Required Response!!" G:$D(DIRUT) RDR2 S FBRR=X
14 D STUFFT G RDMORT
15STUFFT D REJT^FBAADD S FBAAAP=$P(^FBAAC(J,3,K,0),"^",3),$P(FZ,"^",9)=($P(FZ,"^",9)-FBAAAP),$P(FZ,"^",11)=($P(FZ,"^",11)-1),$P(FZ,"^",17)="Y",FBAARA=FBAARA+FBAAAP K QQ(HX)
16 S $P(^FBAA(161.7,B,0),"^",9)=$P(FZ,"^",9),$P(^(0),"^",11)=$P(FZ,"^",11),$P(^(0),"^",17)="Y"
17 Q
18RDMORT S DIR(0)="Y",DIR("A")="Item Rejected! Want to reject another",DIR("B")="YES" D ^DIR K DIR Q:$D(DIRUT) G RLT:Y
19 G DELT
20DELP ;PHARMACY LINE ITEM REJECT
21RDI K QQ W !! S DIC="^FBAAA(",DIC(0)="AEMQ" D ^DIC Q:X="^"!(X="") G:Y<0 RDI S DFN=+Y I '$D(^FBAA(162.1,"AJ",B,DFN)) W !!,*7,"No payments in this batch for that patient!" G RDI
22 S (FBAAOUT,QQ,TM1,TM2)=0 W @IOF D HED^FBAACCB
23 F W1=0:0 S W1=$O(^FBAA(162.1,"AJ",B,DFN,W1)) Q:W1'>0!(FBAAOUT) F W2=0:0 S W2=$O(^FBAA(162.1,"AJ",B,DFN,W1,W2)) Q:W2'>0!(FBAAOUT) S (A,FBIN)=W1,B2=W2,QQ=QQ+1,QQ(QQ)=A_"^"_B2 S Z(0)=^FBAA(162.1,A,"RX",B2,0) D SETV^FBAACCB0,MORE^FBAACCB1
24RLP1 S DIR(0)="Y",DIR("A")="Reject all line items for this patient",DIR("B")="YES" D ^DIR K DIR G DELP:$D(DIRUT),LOOPP:Y
25RLP S DIR(0)="NO^1:"_QQ,DIR("A")="Reject which line item" D ^DIR K DIR G DELP:X=""!$D(DIRUT) S HX=X
26 I '$D(QQ(HX)) W !!,*7,"You just did that one!" G RLP
27RLI S DIR(0)="Y",DIR("A")="Are you sure you want to reject line item number: "_HX,DIR("B")="NO" D ^DIR K DIR G RLP:$D(DIRUT)!'Y
28 S A=$P(QQ(HX),"^",1),B2=$P(QQ(HX),"^",2),J=A,K=B2,FBRFLAG=1,XMB(2)="some"
29RDR3 S DIR(0)="F^2:40",DIR("A")="Enter reason for rejecting" D ^DIR K DIR W:$D(DIRUT) !!,"Required Response!!" G:$D(DIRUT) RDR3 S FBRR=X
30 D STUFFP G RDMORP
31STUFFP D REJP^FBAADD S FBAAAP=$P(^FBAA(162.1,A,"RX",B2,0),"^",16),$P(FZ,"^",9)=($P(FZ,"^",9)-FBAAAP),$P(FZ,"^",11)=($P(FZ,"^",11)-1),$P(FZ,"^",17)="Y",$P(^FBAA(161.7,B,0),"^",9)=$P(FZ,"^",9),$P(^(0),"^",11)=$P(FZ,"^",11),$P(^(0),"^",17)="Y"
32 S FBAARA=FBAARA+FBAAAP K QQ(HX)
33 Q
34RDMORP S DIR(0)="Y",DIR("A")="Item rejected, want to reject another",DIR("B")="YES" D ^DIR K DIR Q:$D(DIRUT) G RLP:Y
35 G DELP
36GET K QQ W !! S DIC="^FBAAA(",DIC(0)="AEQM" D ^DIC Q:X=""!(X="^") G:Y<0 GET S DA=+Y,J=DA Q
37LOOPT S DIR(0)="F^2:40",DIR("A")="Reason for Rejecting" D ^DIR K DIR W:$D(DIRUT) !!,"Required Response!!" G:$D(DIRUT) LOOPT S FBRR=X
38 F HX=0:0 S HX=$O(QQ(HX)) Q:HX'>0 S J=$P(QQ(HX),"^",1),K=$P(QQ(HX),"^",2),FBRFLAG=1,XMB(2)="some" D STUFFT
39 W !,"...DONE!" G DELT
40LOOPP S DIR(0)="F^2:40",DIR("A")="Reason for Rejecting" D ^DIR K DIR W:$D(DIRUT) !!,"Required Response!!" G:$D(DIRUT) LOOPP S FBRR=X
41 F HX=0:0 S HX=$O(QQ(HX)) Q:HX'>0 S A=$P(QQ(HX),"^",1),B2=$P(QQ(HX),"^",2),J=A,K=B2,FBRFLAG=1,XMB(2)="some" D STUFFP
42 W !,"...DONE!" G DELP
Note: See TracBrowser for help on using the repository browser.