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

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

initial load of WorldVistAEHR
File size: 8.9 KB
RevLine 
[613]1IBCU1 ;ALB/MRL - BILLING UTILITY ROUTINE (CONTINUED) ;01 JUN 88 12:00
2 ;;2.0;INTEGRATED BILLING;**27,52,106,138,51,182,210,266,309,320,347**;21-MAR-94;Build 24
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;MAP TO DGCRU1
6 ;
7 ;procedure doesn't appear to be used (6/4/93), if it is used, what for??
8 ;where would multiple provider numbers comde from? ARH
9 ;BCH ;Blue Cross/Shield Help
10 W ! S IB01=$P($G(^IBE(350.9,1,1)),"^",6)
11 I IB01]"" W "CHOOSE FROM",!!?4,"1 - ",$P(IB01,"^",6) F IB00=2,3 I $P(IB01,"^",$S(IB00=2:14,1:15))]"" W !?4,IB00," - ",$P(IB01,"^",$S(IB00=2:14,1:15))
12 W:IB01']"" "NO BLUE CROSS/SHIELD PROVIDER NUMBERS IDENTIFIED TO SELECT FROM!" W ! W:IB01]"" !,"OR " W "ENTER BLUE CROSS/SHIELD PROVIDER # (BETWEEN 3-13 CHARACTERS)",! K IB00,IB01 Q
13 ;
14RCD ;Revenue Code Display
15 Q:'$D(^DGCR(399,IBIFN,"RC"))
16 W @IOF,!,"Revenue Code Listing",?34,"Units",?45,"Charge" W:$$FT^IBCEF(IBIFN)=3 ?56,"Non-Cov"
17 S DGIFN=0 F IBI=0:0 S DGIFN=$O(^DGCR(399,IBIFN,"RC",DGIFN)) Q:'DGIFN I $D(^DGCR(399,IBIFN,"RC",DGIFN,0)) S Z=^(0) D DISRC
18 W !
19 I $D(DIC(0)) S DIC(0)=DIC(0)_"N"
20 Q
21DISRC N Z0 W !?1,DGIFN,?4,$P(^DGCR(399.2,+Z,0),"^"),"-",$E($P(^DGCR(399.2,+Z,0),"^",2),1,19)
22 I +$P(Z,U,6) W ?28,$P($$CPT^ICPTCOD(+$P(Z,U,6)),U,2)
23 W ?36,$P(Z,"^",3),?40 S X=$P(Z,"^",2),X2="2$" D COMMA^%DTC W X
24 I $$FT^IBCEF(IBIFN)=3,$P(Z,U,9)'="" S X=$P(Z,U,9),X2="2$" D COMMA^%DTC W ?51,X
25 I $D(^DGCR(399.1,+$P(Z,"^",5),0)) W ?64,$E($P(^(0),"^"),1,15)
26 I $S($P(Z,U,15):1,1:$P(Z,U,10)=3) D
27 . W !,?5,"(Rx: ",$S($P(Z,U,11):$P($G(^IBA(362.4,$P(Z,U,11),0)),U),1:"Link Missing")," Procedure "_$S($P(Z,U,15):"#"_$P(Z,U,15)_" "_$$CPTNM^IBCRBH1(IBIFN,4,$P(Z,U,15)),1:"Link Missing"),")"
28 Q
29 ;
30RVCPRC(IBIFN,IBD0) ; returns 1 if CHAMPVA rate type + 2 if CMS-1500, 0 otherwise
31 ; IBD0 - zero node of bill if available, not required
32 N X S X=0
33 I $G(IBD0)="" S IBD0=$G(^DGCR(399,+$G(IBIFN),0))
34 I $P($G(^DGCR(399.3,+$P(IBD0,U,7),0)),U,1)="CHAMPVA" S X=X+1
35 I $P(IBD0,U,19)=2 S X=X+2
36 Q X
37 ;
38ORDNXT(IFN) ;CALLED BY TRIGGER ON (362.3,.02) THAT SETS DX PRINT ORDER (362.3,.03),
39 ;returns the highest print order used on the bill plus 3, returns 3 if no existing print order
40 ;used for the default print order so that dx's can be printed in order of entry without any input by the user,
41 ;3 is added to allow spaces for additions, changes, moves
42 N X,Y S X="" I $D(^DGCR(399,+$G(IFN),0)) S X=3,Y=0 F S Y=$O(^IBA(362.3,"AO",+IFN,Y)) Q:'Y S X=Y+3
43 Q X
44 ;
45ORDDUP(ORD,DIFN) ;returns true if print order ORD is already defined for a bill (not same entry)
46 N IBX,IBY S IBY=0
47 I +$G(ORD) S IBX=$G(^IBA(362.3,+$G(DIFN),0)) I +IBX,+$P(IBX,U,3)'=ORD,$D(^IBA(362.3,"AO",+$P(IBX,U,2),+ORD)) S IBY=1
48 Q IBY
49 ;
50DXDUP(DX,DIFN,IFN) ;returns true if DX is already defined for a bill (not same entry)
51 ;either DIFN or IFN can be passed, both are not needed, DIFN is needed during edit so can reenter the same dx
52 N IBX,IBY S IBY=0 I +$G(DX),'$G(IFN) S IBX=$G(^IBA(362.3,+$G(DIFN),0)),IFN=+$P(IBX,U,2)
53 I +$G(DX),$D(^IBA(362.3,"AIFN"_+IFN,+DX)),$O(^IBA(362.3,"AIFN"_+IFN,+DX,0))'=+$G(DIFN) S IBY=1
54 Q IBY
55 ;
56DXBSTAT(DIFN,IFN) ;returns a diagnosis' bill status (either DIFN or IFN can be passed, both are not needed)
57 N IBX,IBY I '$G(IFN) S IBX=$G(^IBA(362.3,+$G(DIFN),0)),IFN=+$P(IBX,U,2)
58 S IBY=+$P($G(^DGCR(399,+IFN,0)),U,13)
59 Q IBY
60 ;
61RXSTAT(DRUG,PIFN,FILLDT) ; returns status/definition of rx
62 ; returns: ORIGINAL ^ RELEASED/RETURNED TO STOCK ^ DRUG DEA
63 N IBX,IBY,IBZ,IBLN,IBNUM S IBLN="",DRUG=+$G(DRUG),PIFN=+$G(PIFN),FILLDT=+$G(FILLDT)
64 ;
65 S IBX=$$RXSEC^IBRXUTL($$FILE^IBRXUTL(PIFN,2),PIFN),IBZ="" I IBX'="",$P(IBX,U,2)=$G(FILLDT) D I IBZ'="" S $P(IBLN,U,2)=IBZ
66 . S IBLN="ORG"
67 . ;I +$G(^PS(59.7,1,49.99))<6 Q
68 . I '$P(IBX,U,13) S IBZ="NR"
69 . I +$P(IBX,U,15) S:IBZ'="" IBZ=IBZ_"-" S IBZ=IBZ_"RTS"
70 ;
71 I IBLN="" S IBNUM=$$RFLNUM^IBRXUTL(PIFN,FILLDT,1),IBX=$$ZEROSUB^IBRXUTL($$FILE^IBRXUTL(PIFN,2),PIFN,IBNUM),IBZ="" I IBX'="" D I IBZ'="" S $P(IBLN,U,2)=IBZ
72 . ;I +$G(^PS(59.7,1,49.99))<6 Q
73 . I '$P(IBX,U,18) S IBZ="NR"
74 . I +$P(IBX,U,16) S:IBZ'="" IBZ=IBZ_"-" S IBZ=IBZ_"RTS"
75 ;
76 D ZERO^IBRXUTL(DRUG)
77 S IBX=$G(^TMP($J,"IBDRUG",0)) I IBX'="" S IBY=$G(^TMP($J,"IBDRUG",DRUG,3)),IBZ="" D I IBZ'="" S $P(IBLN,U,3)=IBZ
78 . I IBY["9" S IBZ="OTC"
79 . I IBY["I" S:IBZ'="" IBZ=IBZ_"-" S IBZ=IBZ_"INV"
80 . I IBY["S" S:IBZ'="" IBZ=IBZ_"-" S IBZ=IBZ_"SUP"
81 K ^TMP($J,"IBDRUG")
82 Q IBLN
83 ;
84PRVLIC(NPIFN,IBDT,ARR,STIFN) ; returns the Provider License data from the New Person file active on a date
85 ; Input: NPIFN = pointer to file 200, IBDT = date to check (if none passed then all returned)
86 ; ARR = array pass by reference (optional), STIFN = state to return as value of function (optional)
87 ; Output: ARR(X) = license state (ifn) ^ license ^ expiration date (200,541)
88 ; return value = license data of state requested or if no state passed in then count found
89 N IBX,IBY,IBLN,IBCNT S IBX=0,IBCNT=0 K ARR
90 I +$G(NPIFN) S IBY=0 F S IBY=$O(^VA(200,NPIFN,"PS1",IBY)) Q:'IBY D
91 . S IBLN=$G(^VA(200,NPIFN,"PS1",IBY,0))
92 . I +$G(IBDT),+$P(IBLN,U,3),$P(IBLN,U,3)<IBDT Q
93 . I +$G(STIFN),+STIFN=+IBLN S IBX=IBLN
94 . S IBCNT=IBCNT+1,ARR(IBCNT)=IBLN
95 S ARR=IBCNT I '$G(STIFN) S IBX=IBCNT
96 Q IBX
97 ;
98DELPR(IB,IBX) ; Deletes the corresponding RX proc when the RX pointer is
99 ; deleted
100 ; IB = the ien of the bill in file 399
101 ; IBX = the ien of the entry in the procedure multiple to be deleted
102 ;
103 N DA,DIK,X,Y
104 S DA(1)=IB,DA=IBX
105 I $D(^DGCR(399,DA(1),"CP",DA,0)) S DIK="^DGCR(399,"_DA(1)_",""CP""," D ^DIK
106 Q
107 ;
108MODHLP(DA) ; Executable modifier help 399.042 .14
109 ; DA = iens of the current entry DA(1) = file 399 ien
110 ; DA = file 399.042 ien
111 N Z,IBZ,DIC,IBDATE
112 S IBDATE=$$BDATE^IBACSV(+$G(DA(1))) ; The date of service
113 I $P($G(^DGCR(399,+$G(DA(1)),"RC",+$G(DA),0)),U,14)'="" S Z=$P(^(0),U,14) D
114 . N Q
115 . S Q=1
116 . S IBZ(1)="Current modifier"_$S($P(Z,";",2)'="":"s are:",1:"is:")
117 . I $P(Z,";")'="" S Q=Q+1,IBZ(Q)=" "_$P(Z,";")_" "_$P($$MOD^ICPTMOD($P(Z,";"),"E",IBDATE),U,3)
118 . I $P(Z,";",2)'="" S Q=Q+1,IBZ(Q)=" "_$P(Z,";",2)_" "_$P($$MOD^ICPTMOD($P(Z,";",2),"E",IBDATE),U,3)
119 . S Q=Q+1,IBZ(Q)=" "
120 . D EN^DDIOL(.IBZ)
121 ;
122 S DIC="^DIC(81.3,",DIC(0)="E"
123 S DIC("S")="I $$MODP^ICPTMOD($P($G(^DGCR(399,DA(1),""RC"",DA,0)),U,6),Y,""I"",IBDATE)>0"
124 S DIC("W")="W ?14,$P($$MOD^ICPTMOD(Y,""I"",IBDATE),U,3)"
125 D ^DIC
126 Q
127 ;
128QMED(IBRTN,IBIFN) ; DSS QuadraMed Interface: DSS/QuadraMed Available
129 ; return 1 if QuadraMed Interface is On and available for the type of bill
130 ; - routine must exist on the system (interface is 'On')
131 ; Input: IBRTN = tag^routine, if it exists then Interface is 'On'
132 ; IBIFN = Bill IFN, bill to check if appropriate for sending to QuadraMed
133 ;
134 N IBON S IBON=0
135 I +$G(IBIFN),$G(IBRTN)'="",$T(@IBRTN)'="" S IBON=1
136 Q IBON
137 ;
138ATTREND(IBIFN,IBIFN1,FIELD) ; This function is called from Mumps Cross References in the claim file 399 and
139 ; also the PROVIDER subfile 399.0222.
140 ;
141 ; IBIFN = IEN to claim file
142 ; IBIFN1 = IEN to provider sub-file in claim file
143 ; FIELD = Field in sub-file being modified (the triggering event). If field has no value, all 6 fields are
144 ; possibly updated
145 ;
146 ; The following fields are the "triggering" events
147 ; File 399
148 ; #19 FORM TYPE - This triggers all 6 fields (122, 123, 124, 128, 129, 130).
149 ;
150 ; Sub-File 399.0222
151 ; #.05 PRIMARY INS CO ID NUMBER triggers 122
152 ; #.06 SECONDARY INS CO ID NUMBER triggers 123
153 ; #.07 TERTIARY INS CO ID NUMBER triggers 124
154 ; #.12 PRIM INS PROVIDER ID TYPE triggers 128
155 ; #.13 SEC INS PROVIDER ID TYPE triggers 129
156 ; #.14 TERT INS PROVIDER ID TYPE triggers 130
157 ;
158 ; The following fields are the ones being "triggered"
159 ; #122 PRIMARY PROVIDER #
160 ; #123 SECONDARY PROVIDER #
161 ; #124 TERTIARY PROVIDER #
162 ; #128 PRIMARY ID QUALIFER
163 ; #129 SECONDARY ID QUALIFIER
164 ; #130 TERTIARY ID QUALIFIER
165 ;
166 Q:$G(IBPRCOB) ; this is set when creating an MRA scondary claim. Don't want to be changing the data on
167 ; a secondary claim
168 ;
169 N FT,DATA,I,PC,INS,IFUNC,ATTRENDD,IBDR
170 S FT=$$FT^IBCEF(IBIFN)
171 Q:'FT
172 ;
173 S IFUNC=$O(^DGCR(399,IBIFN,"PRV","B",$S(FT=3:4,1:3),""))
174 I $G(IBIFN1),$G(IFUNC)'=IBIFN1 Q ; if called from subfile, quits if att/rend provider was not the one being modified
175 S ATTRENDD=$S('$G(IFUNC):"",1:$G(^DGCR(399,IBIFN,"PRV",IFUNC,0)))
176 ;
177 S PC=$S(FT=2:6,FT=3:8,1:"") ; get the correct piece from the ins co dictionary
178 Q:'+PC
179 ;
180 F I="I1","I2","I3" D
181 . S INS=$P($G(^DGCR(399,IBIFN,I)),U)
182 . Q:'+INS
183 . Q:'$P($G(^DIC(36,INS,4)),U,PC)
184 . D:I="I1"
185 .. S:".05"[FIELD IBDR(399,IBIFN_",",122)=$S($P(ATTRENDD,U,5)]"":$P(ATTRENDD,U,5),1:"@")
186 .. S:".12"[FIELD IBDR(399,IBIFN_",",128)=$S($P(ATTRENDD,U,12)]"":$P(ATTRENDD,U,12),1:"@")
187 . D:I="I2"
188 .. S:".06"[FIELD IBDR(399,IBIFN_",",123)=$S($P(ATTRENDD,U,6)]"":$P(ATTRENDD,U,6),1:"@")
189 .. S:".13"[FIELD IBDR(399,IBIFN_",",129)=$S($P(ATTRENDD,U,13)]"":$P(ATTRENDD,U,13),1:"@")
190 . D:I="I3"
191 .. S:".07"[FIELD IBDR(399,IBIFN_",",124)=$S($P(ATTRENDD,U,7)]"":$P(ATTRENDD,U,7),1:"@")
192 .. S:".14"[FIELD IBDR(399,IBIFN_",",130)=$S($P(ATTRENDD,U,14)]"":$P(ATTRENDD,U,14),1:"@")
193 ;
194 I $O(IBDR(0)) D FILE^DIE("","IBDR")
195 Q
Note: See TracBrowser for help on using the repository browser.