source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBNCPDPR.m@ 691

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

initial load of WorldVistAEHR
File size: 5.0 KB
RevLine 
[613]1IBNCPDPR ;WOIFO/SS - ECME RELEASE CHARGES ON HOLD ;JUNE 08 2005
2 ;;2.0;INTEGRATED BILLING;**276,347**;21-MAR-94;Build 24
3 ;; Per VHA Directive 2004-038, this routine should not be modified.
4 Q
5 ;==========
6 ;version of "IB MT RELEASE CHARGES" option (^IBREL) without PATIENT prompt
7 ;(patient is selected from the User Screen)
8 ;designed to use from ECME User Screen (IA #) in order to access Release
9 ;copay functionality from ECME
10 ;
11RELH(DFN,IBRXIEN,IBREFL,IBMODE) ;
12 Q:$$PFSSON^IBNCPDPI() ;quit if PFSS is ON
13 K IBA,PRCABN,BPX,IBI,IBCNT,IB350
14 S IB350=0
15 S IBI=0 F IBNUM=1:1 S IBI=$O(^IB("AH",DFN,IBI)) Q:'IBI S IBA(IBNUM)=IBI
16 I '$D(IBA) W !!,"This patient does not have any charges 'on hold.'",! G ASK
17 ;
18 S IBPT=$$PT^IBEFUNC(DFN) W @IOF,$P(IBPT,"^")," Pt ID: ",$P(IBPT,"^",2),! S I="",$P(I,"-",80)="" W I K I
19 ;if the user selected specific RX/refill
20 I IBMODE="C" D S:IB350>0 DIR("B")=$P(IB350,U,2)
21 . ;find item that matches selected RX/refill
22 . S IBCNT=0
23 . F S IBCNT=$O(IBA(IBCNT)) Q:+IBCNT=0 D Q:IB350>0
24 . . S BPX=$P($G(^IB(IBA(IBCNT),0)),U,4)
25 . . I $P(BPX,":")'=52 Q ;if not RX type
26 . . I $P($P(BPX,";"),":",2)'=IBRXIEN Q ;if not given RX#
27 . . I IBREFL>0 I $P($P(BPX,";",2),":",2)'=IBREFL Q ;if not given refill #
28 . . S IB350=IBA(IBCNT)_"^"_IBCNT
29 ;
30 I IBMODE="C",IB350=0 D G ASK
31 . W !!,"There is no copay charge 'on hold' for this Rx.",!
32 . D PAUSE^VALM1
33 D RESUME
34 Q
35 ;
36 ;
37ASK ;stub for ASK
38 Q
39 ;
40 ;the following code was borrowed from IBRREL without changes.
41 ;This was done to avoid code changes in the original code and
42 ;re-testing it in IB package
43 ; - display header and list charges
44RESUME W !!,"The following IB Actions ",$S($D(PRCABN):"associated with this bill",1:"for this patient")," are ON HOLD:" D HDR
45 S IBQ=0 F IBNUM=1:1 Q:'$D(IBA(IBNUM)) D:'(IBNUM#15) Q:IBQ S IBN=IBA(IBNUM) D LST
46 . R !,"Enter RETURN to continue or '^' to stop: ",X:DTIME S:X["^"!('$T) IBQ=1 Q
47 ;
48 ; - prompt user to select IB Actions
49 S DIR(0)="LA^1:"_(IBNUM-1)_"^K:X[""."" X",DIR("A")="Select IB Action"_$E("s",IBNUM>2)_" (REF #) to release (or '^' to exit): ",DIR("?")="^D HELP^IBRREL"
50 W ! D ^DIR K DIR I $D(DIRUT)!($D(DUOUT)) G END:$D(PRCABN) D END W ! G ASK
51 ;
52 S IBRANGE=Y,IBSEQNO=1,IBDUZ=DUZ
53 ;
54 S DIR(0)="Y",DIR("A")="OK to pass "_$S($P(Y,",",2):"these charges",1:"this charge")_" to Accounts Receivable"
55 D ^DIR K DIR I 'Y!($D(DIRUT))!($D(DUOUT)) G END:$D(PRCABN) D END W ! G ASK
56 ;
57 ; - pass charges to Accounts Receivable
58 W !!,"Passing charges to Accounts Receivable...",! D HDR
59 F IBCTR=1:1 S IBNUM=$P(IBRANGE,",",IBCTR) Q:'IBNUM I $D(IBA(IBNUM)) S IBNOS=IBA(IBNUM) D ^IBR,ERR:Y<1 I Y>0 S IBN=IBA(IBNUM) D LST
60 W !!,"The charge"_$E("s",$P(IBRANGE,",",2)>0)_" listed above "_$S($P(IBRANGE,",",2):"have",1:"has")_" been passed to Accounts Receivable.",!
61 ;
62 I '$D(PRCABN) W !! S DIR(0)="E" D ^DIR K DIR D END W ! G ASK
63 ;
64END K DIC,DIRUT,DUOUT,DTOUT,IBA,IBAFY,IBARTYP,IBATYP,IBCTR,IBN,IBDA,IBDUZ
65 K IBFAC,IBI,IBIL,IBRANGE,IBNOS,IBNUM,IBPT,IBQ,IBSEQNO,IBSERV,IBSITE
66 K IBTOTL,IBTRAN,IBWHER,VA,VAERR,VADM
67 K:'$D(PRCABN) DFN
68 ;***
69 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBRREL" D T1^%ZOSV ;stop rt clock
70 Q
71 ;
72 ;
73HDR ; Display charge header.
74 N IBLINE S $P(IBLINE,"=",81)=""
75 W !,IBLINE,!," REF Action ID Bill Type",?42,"Bill #",?51,"Fr/Fl Dt",?61,"To/Rls Dt",?73,"Charge"
76 W !,IBLINE Q
77 ;
78LST ; Display individual IB Action.
79 N IBND,IBND1,IBRXN,IBRX,IBRF,IBRDT,IENS
80 S IBND=$G(^IB(IBN,0)),IBND1=$G(^IB(IBN,1)),(IBRXN,IBRX,IBRF,IBRDT)=0
81 I $P(IBND,"^",4)["52:" S IBRXN=$P($P(IBND,"^",4),":",2),IBRX=$P($P(IBND,"^",8),"-"),IBRF=$P($P(IBND,"^",4),":",3)
82 I $P(IBND,"^",4)["52:" D
83 .I IBRF>0 S IENS=+IBRF,IBRDT=$$SUBFILE^IBRXUTL(+IBRXN,+IENS,52,.01)
84 .E S IENS=+IBRXN,IBRDT=$$FILE^IBRXUTL(+IENS,22)
85 W !?1,$J(IBNUM,2),?7,$J(+IBND,9)
86 W ?18,$S(IBRXN>0:"Rx #: "_IBRX_$S(IBRF>0:"("_IBRF_")",1:""),1:$P($G(^IBE(350.1,+$P(IBND,"^",3),0)),"^",8))
87 W ?42,$P($P(IBND,"^",11),"-",2)
88 W ?51,$$DAT1^IBOUTL($S(IBRXN>0:IBRDT,1:$P(IBND,"^",14)))
89 W ?61,$$DAT1^IBOUTL($S($P(IBND,"^",15)'="":($P(IBND,"^",15)),1:$P(IBND1,"^",2)))
90 W ?70,$J(+$P(IBND,"^",7),9,2)
91 Q
92 ;
93ERR ; Display error message.
94 W !?1,$J(IBNUM,2),?7,"Error encountered - a separate bulletin has been posted"
95 Q
96 ;
97HLP ; Display basic help message.
98 W !!,"Enter: the name of a patient with charges 'on hold,' or"
99 W !?10,"'??' -- to see all patients with charges 'on hold,' or"
100 W !?10,"'^' -- to quit this option.",!
101 Q
102 ;
103HLP1 ; Display all patients with charges 'on hold.'
104 N DFN,I,IBQ,PID
105 W !!,"The following patients have charges 'on hold:'"
106 S (DFN,IBQ)=0 F I=1:1 S DFN=$O(^IB("AH",DFN)) Q:'DFN D:'(I#15) Q:IBQ S PID=$$PT^IBEFUNC(DFN) W !?3,$P(PID,"^"),$J("",10),$P(PID,"^",2)
107 . R !,"Enter RETURN to continue or '^' to stop: ",X:DTIME S:X["^"!('$T) IBQ=1 Q
108 W ! Q
109 ;
110HELP ; Help for the 'Select' prompt.
111 W !!?4,"Please enter a list or range of IB Actions (i.e. 1,3,5 or 2-4,8), none"
112 W !?4,"greater than ",IBNUM-1,", to be passed to Accounts Receivable, or '^' to quit."
113 Q
114 ;
115 ;
116AR ; Accounts Receivable entry point to release charges.
117 ; Input: PRCABN -- ien of Bill/Accounts Receivable
118 Q:$D(PRCABN)[0 Q:'$$IB^IBRUTL(PRCABN,1) G RESUME
119 ;
Note: See TracBrowser for help on using the repository browser.