source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBARX1.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: 4.3 KB
Line 
1IBARX1 ;ALB/AAS - INTEGRATED BILLING, PHARMACY COPAY INTERFACE (CONT.) ;21-FEB-91
2 ;;2.0;INTEGRATED BILLING;**34,101,150,158,156,234,247**;21-MAR-94
3 ;;Per VHA Directive 10-93-142 ;This routine should not be modified.
4 ;
5 ; - process 1 rx entry and accumulate totals
6 ;
7RX N IBAM,IBNOCH
8 ;if Combat Vet send alert e-mail to mailgroup "IB COMBAT VET RX COPAY"
9 D
10 . N Y D NOW^%DTC S Y=%\1
11 . D RXALRT^IBACV(DFN,Y,+$P($P($G(IBSAVX(1)),"^",1),":",2))
12 ;
13 I $P(IBX,"^")'?1.N1":"1.N.ANP S Y="-1^IB012" G RXQ
14 I $P(IBX,"^",2)<1 S Y="-1^IB013" G RXQ
15 ;
16 D BDESC
17 ;
18 S DA=IBATYP D COST^IBAUTL
19 ;
20 ; compute amount above cap
21 D NEW^IBARXMC($P(IBX,"^",2),X1,DT,.IBCHRG,.IBNOCH)
22 ;
23 S IBTCH=$P(IBX,"^",2)*X1
24 ;
25 ; add to 354.71
26 S IBAM=$$ADD^IBARXMN(DFN,"^^"_$S($G(IBEFDT):IBEFDT,1:DT)_"^^P^"_$P(IBX,"^")_"^"_$P(IBX,"^",2)_"^"_IBTCH_"^"_IBDESC_"^"_$S($G(IBAMP):IBAMP,1:"")_"^"_IBCHRG_"^"_IBNOCH_"^"_(+$P($$SITE^IBARXMU,"^",3)),IBATYP) I IBAM<1 S Y="-1^IB316" G RXQ
27 ;
28 ; setup new pieces (4, 5, 6, and 7), quit if above cap
29 S $P(IBSAVY(IBJ),"^",4,7)=$S(IBNOCH:1,1:0)_"^"_$S(IBNOCH&(IBCHRG):"P",IBCHRG:"F",1:"")_"^"_(+$G(IBEXMP))_"^"_IBAM G:'IBCHRG RXQ
30 ;
31 S IBTOTL=IBTOTL+IBCHRG
32 S IBWHER=2
33 D ADD^IBAUTL
34 I +Y<1 G RXQ
35 S IBPARNT=$S($D(IBPARNT):IBPARNT,1:IBN)
36 S $P(^IB(IBN,1),"^",1)=IBDUZ,$P(^IB(IBN,0),"^",2,13)=DFN_"^"_IBATYP_"^"_$P(IBX,"^")_"^2^"_$P(IBX,"^",2)_"^"_IBCHRG_"^"_IBDESC_"^"_IBPARNT_"^^"_IBIL_"^"_IBTRAN_"^"_IBFAC,$P(^(0),"^",19)=IBAM
37 K IBPARNT,^IB("AC",1,IBN) ;S ^IB("AC",2,IBN)=""
38 D INDEX
39 S $P(IBSAVY(IBJ),"^",1,3)=IBN_"^"_IBCHRG_"^"_IBIL
40 S:'$D(IBNOS) IBNOS="" S IBNOS=IBN_"^"_IBNOS
41RXQ Q
42 ;
43CANRX ; - ibx = ibn for parent entry
44 ; - ibn = new cancellation entry
45 N IBAM,IBAMY
46 S IBY(IBJ)=1
47 I '$D(^IBE(350.3,+$P(IBX,"^",2),0)) S (Y,IBY(IBJ))="-1^IB020" G CANRXQ
48 I '$D(^IB(+IBX,0)) S (Y,IBY(IBJ))="-1^IB021" G CANRXQ
49 S IBND=^IB(+IBX,0)
50 S IBCRES=$P(IBX,"^",2)
51 ; -find most recent entry for parent ibx
52 ; -if status isn't an update or new, error already cancelled?
53 D LAST I IBLAST'=IBPARNT,$D(^IB(IBLAST,0)),$P(^IBE(350.1,$P(^IB(IBLAST,0),"^",3),0),"^",5)=2 S (Y,IBY(IBJ))="-1^IB026^ Ref. No: "_+^IB(+IBLAST,0) G CANRXQ ;already cancelled
54 ;
55 ; cancel 354.71
56 S IBAM=$$CANCEL^IBARXMN(DFN,$P(IBND,"^",19),.IBAMY,IBCRES) I $G(IBAMY)<0 S (Y,IBY(IBJ))=IBAMY G CANRXQ
57 ;
58 I $P(IBND,"^",5)=8 D QUIT ;Cancel a charge with a status of HOLD
59 . N DIE,DA,DR
60 . S DIE="^IB(",DA=+IBX,DR=".05////10;.1////"_IBCRES
61 . DO ^DIE
62 . S Y=1,IBY(IBJ)=1,Y(IBJ)=+IBX
63 ;
64 S IBPARNT=$P(IBND,"^",9) I '$D(^IB(IBPARNT,0)) S (Y,IBY(IBJ))="-1^IB027" G CANRXQ
65 S IBATYP=$P(^IBE(350.1,$P(IBND,"^",3),0),"^",6) ;cancellation action type for parent
66 I '$D(^IBE(350.1,+IBATYP,0)) S (Y,IBY(IBJ))="-1^IB022" G CANRXQ
67 S IBSEQNO=$P(^IBE(350.1,+IBATYP,0),"^",5) I 'IBSEQNO S (Y,IBY(IBJ))="-1^IB023" G CANRXQ
68 S IBIL=$P(IBND,"^",11) I IBIL="" S (Y,IBY(IBJ))="-1^IB024" G CANRXQ
69 S IBUNIT=$S($D(^IB(+IBLAST,0)):$P(^(0),"^",6),1:$P(IBND,"^",6)) I IBUNIT<1 S (Y,IBY(IBJ))="-1^IB025" G CANRXQ
70 S IBCHRG=$S($D(^IB(+IBLAST,0)):$P(^(0),"^",7),1:$P(IBND,"^",7)) I IBCHRG<1 S (Y,IBY(IBJ))="-1^IB025" G CANRXQ
71 S IBTOTL=IBTOTL+IBCHRG
72 S IBWHER=2
73 D ADD^IBAUTL I +Y<1 S IBY(IBJ)=Y G CANRXQ
74 S $P(^IB(IBN,1),"^",1)=IBDUZ,$P(^IB(IBN,0),"^",2,13)=DFN_"^"_IBATYP_"^"_$P(IBND,"^",4)_"^2^"_IBUNIT_"^"_IBCHRG_"^"_$P(IBND,"^",8)_"^"_IBPARNT_"^"_IBCRES_"^"_IBIL_"^^"_IBFAC S:IBAM $P(^(0),"^",19)=IBAM
75 K ^IB("AC",1,IBN) ;S ^IB("AC",2,IBN)=""
76 D INDEX
77 S Y(IBJ)=IBN_"^"_IBCHRG_"^"_IBIL
78 S IBNOS=IBN
79CANRXQ Q
80 ;
81BDESC ; -return brief description
82 N X,Y S IBDESC="",X=$P(IBX,"^")
83 I $D(^IBE(350.1,IBATYP,20)) X ^(20) S IBDESC=X
84 Q
85LAST ;find last entry
86 S IBLAST=""
87 S IBPARNT=$P(^IB(+IBX,0),"^",9) I 'IBPARNT S IBPARNT=+IBX
88 S IBLDT=$O(^IB("APDT",IBPARNT,"")) I +IBLDT F IBL=0:0 S IBL=$O(^IB("APDT",IBPARNT,IBLDT,IBL)) Q:'IBL S IBLAST=IBL
89 I IBLAST="" S IBLAST=IBPARNT
90 Q
91 ;
92INDEX ;cross-reference entry
93 N X,Y
94 S DA=IBN,DIK="^IB(" D IX^DIK
95 K DIK Q
96 ;
97SERV(Y) ; -- Service check for Pharmacy
98 ; called by the screen in the input transform for the IB SERVICE/SECTION
99 ; field of the PHARMACY SITE file.
100 ; input = Y internal entry number in service section file
101 ; output = 1 if okay to use (service matches) or 0 if not okay
102 ;
103 ; -- screen logic for field 1003 in file 59 should be
104 ; S DIC("S")="I $$SERV^IBARX1(+Y)"
105 ;
106 Q $S('$G(Y):0,1:$D(^IBE(350.1,"ANEW",Y,1,1))&$D(^IBE(350.1,"ANEW",Y,1,2)))
Note: See TracBrowser for help on using the repository browser.