Changeset 636 for FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATER.m

r628	r636
1	1	IBATER ;LL/ELZ - TRANSFER PRICING PROSTHETICS DRIVER ; 7-APR-2000
2		;;2.0;INTEGRATED BILLING;115~~,389;21-MAR-94;Build 6~~
3		;;Per VHA Directive ~~2004-038~~, this routine should not be modified.
	2	;;2.0;INTEGRATED BILLING;115;21-MAR-94
	3	;;Per VHA Directive 10-93-142, this routine should not be modified.
4	4	;
5	5	; This routine is called by the nightly back ground job. It will go
…	…
22	22	CHECK ; check if transfer pricing and not already added
23	23	;
24		N IBDATA,IBD~~ATA1,IBD~~FN
	24	N IBDATA,IBDFN
25	25	;
26	26	; already in file
…	…
28	28	;
29	29	; valid tp patient
30		S IBDATA=$G(^RMPR(660,+IBDA,0)) Q:IBDATA="" ~~S IBDATA1=$G(^RMPR(660,+IBDA,1))~~
	30	S IBDATA=$G(^RMPR(660,+IBDA,0)) Q:IBDATA=""
31	31	S IBDFN=$P(IBDATA,"^",2) Q:'IBDFN Q:'$$TPP^IBATUTL(IBDFN)
32	32	;
33	33	; checks from RMPRBIL copied 4/7/2000 with mod for patient type removed
34		I $S('$D(^RMPR(660,IBDA,"AM")):1,$P(IBDATA,"^",9)="":1,$P(IBDATA,"^",12)="":1,$P(IBDATA~~1,"^",4~~)="":1,$P(IBDATA,"^",14)="V":1,$P(IBDATA,"^",15)="*":1,1:0) Q
	34	I $S('$D(^RMPR(660,IBDA,"AM")):1,$P(IBDATA,"^",9)="":1,$P(IBDATA,"^",12)="":1,$P(IBDATA,"^",6)="":1,$P(IBDATA,"^",14)="V":1,$P(IBDATA,"^",15)="*":1,1:0) Q
35	35	;
36	36	; now if inpt, must be in 351.67
37		I $P(^RMPR(660,IBDA,"AM"),"^",3)'=1,$P(^("AM"),"^",3)'=4,'$D(^IBAT(351.67,"B",$P(IBDATA~~1,"^",4~~))) Q
	37	I $P(^RMPR(660,IBDA,"AM"),"^",3)'=1,$P(^("AM"),"^",3)'=4,'$D(^IBAT(351.67,"B",$P(IBDATA,"^",6))) Q
38	38	;
39	39	Q:'$P(IBDATA,"^",16) ; no total cost, at least yet
…	…
41	41	FILE ; ok transaction needs to be filled in tp files
42	42	;
43		S IBDATA=$$RMPR^IBATFILE(IBDFN,IBDT,$$PPF^IBATUTL(IBDFN),(IBDA_";RMPR(660,"),,$P(IBDATA,"^",16))
	43	S IBDATA=$$RMPR^IBATFILE(IBDFN,IBDT,$$PPF^IBATUTL(IBDFN),(IBDA_";RMPR(660,"),$P(IBDATA,"^",6),$P(IBDATA,"^",16))
44	44	;
45	45	Q

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATFILE.m

-              r628
+              r636
 IBATFILE ;LL/ELZ - TRANSFER PRICING FILLING  ; 22-JAN-1999
  ;;2.0;INTEGRATED BILLING;**115,389**;21-MAR-94;Build 6
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**115**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
 PAT(DA,IBFAC,IBOVER) ; files patient in transfer pricing returns dfn
  Q:'$G(DA) 0
 …
  ; DFN=dfn for patient, IBEDT=event date, IBPREF=enrolled facility
  ; IBSOURCE=source (prost ien;RMPR(660,
  ; IBPROS=ien from file 661 - removed in 389 no longer valid
+ ; IBPROS=ien from file 661
  ; IBCOST=item cost
  I '$G(DFN)!('$G(IBEDT))!('$G(IBPREF))!($G(IBSOURCE)="") Q 0
+ I '$G(DFN)!('$G(IBEDT))!('$G(IBPREF))!($G(IBSOURCE)="")!('$G(IBPROS)) Q 0
  N IBIEN
  S IBIEN=$$NEW(DFN,IBEDT,IBPREF,IBSOURCE) I 'IBIEN Q IBIEN
  S DIE="^IBAT(351.61,",DA=IBIEN
  S DR=".1////"_+IBEDT_";.05////"_$S($G(IBCOST):"P;4.05////"_+IBCOST_";.13////"_DT,1:"C")
+ S DR=".1////"_+IBEDT_";4.04////"_+IBPROS_";.05////"_$S($G(IBCOST):"P;4.05////"_+IBCOST_";.13////"_DT,1:"C")
  L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked"
  D ^DIE D:$G(IBCOST) TOTAL^IBATCM(IBIEN)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATLM1B.m

-              r628
+              r636
 IBATLM1B ;LL/ELZ - TRANSFER PRICING TRANSACTION LIST MENU ; 15-SEP-1998
  ;;2.0;INTEGRATED BILLING;**115,261,389**;21-MAR-94;Build 6
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**115,261**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
 CF ; -- change facility from patient level
 …
+ Q
 R ; -- select an prosthetic
  N IBBDT,IBEDT,IBCOUNT,IBOUT,IBDA,IBDATA,IBDATA1,IBP,IBC,IBCOUNT,%,DIRUT
+ N IBBDT,IBEDT,IBCOUNT,IBOUT,IBDA,IBDATA,IBP,IBC,IBCOUNT,%,DIRUT
+ ;
  S (IBCOUNT,IBOUT)=0
 …
  . ;
  . ; valid data
  . S IBDATA=$G(^RMPR(660,+IBDA,0)) Q:IBDATA=""  S IBDATA1=$G(^RMPR(660,+IBDA,1))
+ . S IBDATA=$G(^RMPR(660,+IBDA,0)) Q:IBDATA=""
  . ;
  . ; valid date range
 …
  . ;
  . ; checks from RMPRBIL copied 4/7/2000 with mod for AM node patients
  . I $S('$D(^RMPR(660,IBDA,"AM")):1,$P(IBDATA,"^",9)="":1,$P(IBDATA,"^",12)="":1,$P(IBDATA1,"^",4)="":1,$P(IBDATA,"^",14)="V":1,$P(IBDATA,"^",15)="*":1,1:0) Q
+ . I $S('$D(^RMPR(660,IBDA,"AM")):1,$P(IBDATA,"^",9)="":1,$P(IBDATA,"^",12)="":1,$P(IBDATA,"^",6)="":1,$P(IBDATA,"^",14)="V":1,$P(IBDATA,"^",15)="*":1,1:0) Q
  . ;
  . ; set array
 …
  . S IBDATA=IBP(IBC,$O(IBP(IBC,0)))
  . W !,IBC,?4,$$FMTE^XLFDT($P(IBDATA,"^",12),"5D")
  . W ?20,$E($P($$PIN^IBATUTL($O(IBP(IBC,0))),U,2),1,28),?50,"("
+ . W ?20,$$EX^IBATUTL(660,4,$P(IBDATA,"^",6)),?40,"("
  . W $$EX^IBATUTL(660,62,$P(^RMPR(660,$O(IBP(IBC,0)),"AM"),"^",3)),")"
  . W ?65,$J($FN($P(IBDATA,"^",16),",",2),12)
 …
  I $D(DIRUT) D H Q
  W !!,"Adding Transaction number ",$$SITE^IBATUTL
  W $$RMPR^IBATFILE(DFN,$P(IBDATA,"^",12),$$PPF^IBATUTL(DFN),(IBDA_";RMPR(660,"),,$P(IBDATA,"^",16))
+ W $$RMPR^IBATFILE(DFN,$P(IBDATA,"^",12),$$PPF^IBATUTL(DFN),(IBDA_";RMPR(660,"),$P(IBDATA,"^",6),$P(IBDATA,"^",16))
  W "!" H 1
  D H

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATLM2A.m

-              r628
+              r636
 IBATLM2A ;LL/ELZ - TRANSFER PRICING PT TRANSACTION DETAIL ; 15-SEP-1998
  ;;2.0;INTEGRATED BILLING;**115,210,266,309,389**;21-MAR-94;Build 6
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**115,210,266,309**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
  N IBX,IBY K ^TMP("IBATEE",$J)
 …
  D SETVALM(.VALMCNT,"")
  D SET("Prosthetic Item:",.IBY,5,16)
  D SET($P($$PIN^IBATUTL(+$P(IBDATA(0),"^",12)),U,2),.IBY,23,30) ; dbia 374
  D SET($FN($P(IBDATA(4),"^",5),",",2),.IBY,58,15)
+ D SET($$GET1^DIQ(661,$P(IBDATA(4),"^",4),.01),.IBY,12,40) ; dbia 374
+ D SET($FN($P(IBDATA(4),"^",5),",",2),.IBY,55,15)
  D SETVALM(.VALMCNT,.IBY)
  D SETVALM(.VALMCNT,"")

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATO1.m

-              r628
+              r636
 IBATO1 ;LL/ELZ - TRANSFER PRICING REPORTS CONT. ; 18-DEC-98
  ;;2.0;INTEGRATED BILLING;**115,266,389**;21-MAR-94;Build 6
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**115,266**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
 PAGE() ; performs page reads and returns 1 if quiting is needed
 …
  . S IBD(1,IBO,IBB)=$E($$EX^IBATUTL(351.61,4.01,+IBA(4)),1,18)
  I $P(IBA(0),"^",12)["RMPR(660," D  Q
  . S IBD(1,IBO,IBB)=$E($P($$PIN^IBATUTL(+$P(IBA(0),"^",12)),U,2),1,18)
+ . S IBD(1,IBO,IBB)=$E($$EX^IBATUTL(351.61,4.04,$P(IBA(4),"^",4)),1,18)
  S IBDATE=$P($G(^IBAT(351.61,IBIEN,0)),U,4) ; Event Date
  S IBX=0 F  S IBX=$O(^IBAT(351.61,IBA,3,IBX)) Q:IBX<1  D

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATUTL.m

-              r628
+              r636
 IBATUTL ;LL/ELZ - TRANSFER PRICING UTILITES ; 3-SEP-1998
  ;;2.0;INTEGRATED BILLING;**115,266,347,389**;21-MAR-94;Build 6
+ ;;2.0;INTEGRATED BILLING;**115,266,347**;21-MAR-94;Build 24
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
  Q Z
+ ;
-PIN(P660,P6611) ; return Prosthetics Item Description (#661.1,.02)
- ; input:  P660 - pointer to Patient Item (#660) or P6611 - pointer to HCPCS (#661.1)
- ; return: pointer to HCPCS (#661.1) ^ Short Description (#661.1,.01) ^ HCPCS (#661.1,.01)
- N IBX,IBY S IBY=""
- I +$G(P660) S P6611=+$P($G(^RMPR(660,+P660,1)),U,4)
- I +$G(P6611) S IBX=$G(^RMPR(661.1,+P6611,0)) I IBX'="" S IBY=P6611_U_$P(IBX,U,2)_U_$P(IBX,U,1)
- Q IBY
+ ;
 EX(FILE,FIELD,VALUE) ; -- return external value
  N Y,C S Y=$G(VALUE)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB.m

-              r628
+              r636
 IBCBB ;ALB/AAS - EDIT CHECK ROUTINE TO BE INVOKED BEFORE ALL BILL APPROVAL ACTIONS ;2-NOV-89
  ;;2.0;INTEGRATED BILLING;**80,51,137,288,327,361,371,377**;21-MAR-94;Build 23
+ ;;2.0;INTEGRATED BILLING;**80,51,137,288,327,361**;21-MAR-94;Build 9
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
+ ;
 EN ;Entry to check for errors
  N IBQ,IBXERR,IBXDATA,IBXSAVE,IBZPRC92,IBQUIT,IBISEQ,IDDATA,IBFOR,IBC
+ N IBQ,IBXERR,IBXDATA,IBXSAVE,IBZPRC92,IBQUIT,IBISEQ,IDDATA,IBERRNO
  I $D(IBFL) N IBFL
  K ^TMP($J)
  W !
  S IBER="" D GVAR I '$D(IBND0) S IBER=-1 Q
+ ;
+ ;I $$ISPROS^IBCEF1(IBIFN) D
+ ;. D WARN^IBCBB11("Bill has prosthetics item(s) and will only print locally")
+ ;. I $$NEEDMRA^IBEFUNC(IBIFN) S IBQUIT=$$IBER^IBCBB3(.IBER,"098")
+ ;
  ;patient in patient file
 …
  I IBAT]"",'$D(^DGCR(399.3,IBAT,0)) S IBER=IBER_"IB059;"
  I IBAT]"",$D(^DGCR(399.3,IBAT,0)),'$P(^(0),"^",6) S IBER=IBER_"IB059;",IBAT=""
+ ;I IBAT]"",$D(^DGCR(399.3,IBAT,0)) S IBARTP=$P(^PRCA(430.2,$P(^DGCR(399.3,IBAT,0),"^",6),0),"^",6)
  I IBAT]"",$P($G(^DGCR(399.3,IBAT,0)),"^",6) S IBARTP=$P($$CATN^PRCAFN($P(^DGCR(399.3,IBAT,0),"^",6)),"^",3)
  ;Check that AR category expects same debtor as defined in who's responsible.
 …
  . S IDDATA=$$INSDEM^IBCEF(IBIFN,IBISEQ)
  . K ^UTILITY("VADM",$J),^UTILITY("VAPA",$J)
+ . ;
+ . I '$P(IDDATA,U,1) D ERR(221)   ; birth date missing
+ . ;
+ . I "^M^F^"'[(U_$P(IDDATA,U,2)_U) D ERR(261)  ; sex missing
+ . ;
+ . ; IB*2*371 - esg - check for other missing insurance pieces
+ . ; check insured's name, primary ID#, pt. relationship to insured,
+ . ; and subscriber address data
+ . N INNAME,SUBID,PTREL,SFA,CAS,LN,FN
+ . ;
+ . ;          IB273 - Primary Insurance name of insured missing
+ . ;          IB274 - Secondary Insurance name of insured missing
+ . ;          IB275 - Tertiary Insurance name of insured missing
+ . S INNAME=$$POLICY^IBCEF(IBIFN,17,IBISEQ)
+ . S LN=$P(INNAME,",",1),FN=$P(INNAME,",",2)   ; last name,first name
+ . S LN=$$NOPUNCT^IBCEF(LN,1)
+ . S FN=$$NOPUNCT^IBCEF(FN,1)
+ . I LN=""!(FN="") D ERR(273)   ; name of insured missing or invalid
+ . S LN=$$NAME^IBCEFG1(INNAME)  ; additional name checks
+ . S FN=$P(LN,U,2)
+ . S LN=$P(LN,U,1)
+ . I LN=""!(FN="") D ERR(273)   ; name of insured missing or invalid
+ . ;
+ . ;          IB276 - Primary Insurance subscriber ID missing
+ . ;          IB277 - Secondary Insurance subscriber ID missing
+ . ;          IB278 - Tertiary Insurance subscriber ID missing
+ . S SUBID=$$NOPUNCT^IBCEF($$POLICY^IBCEF(IBIFN,2,IBISEQ),1)
+ . I SUBID="" D ERR(276)     ; subscriber ID# missing
+ . ;
+ . ;          IB279 - Primary Insurance missing pt relationship
+ . ;          IB280 - Secondary Insurance missing pt relationship
+ . ;          IB281 - Tertiary Insurance missing pt relationship
+ . S PTREL=$$POLICY^IBCEF(IBIFN,16,IBISEQ)
+ . I PTREL="" D ERR(279)      ; missing patient relationship to insured
+ . ;
+ . ; subscriber address section
+ . S SFA=$$INSADDR^IBCEF(IBIFN,IBISEQ)     ; full address all pieces
+ . S CAS=$$NOPUNCT^IBCEF($P(SFA,U,2,5),1)  ; string city,st,zip,addr1
+ . ;
+ . ;          IB282 - Primary Insurance address line 1 missing
+ . ;          IB283 - Secondary Insurance address line 1 missing
+ . ;          IB284 - Tertiary Insurance address line 1 missing
+ . I $$NOPUNCT^IBCEF($P(SFA,U,5),1)="" D   ; address line 1 is blank
+ .. ; pat=subscriber and current insurance - address is required
+ .. I +PTREL=1,IBISEQ=$$COBN^IBCEF(IBIFN) D ERR(282) Q
+ .. ; if any part of the address is there, then all fields are required
+ .. I CAS'="" D ERR(282) Q
+ .. Q
+ . ;
+ . ;          IB285 - Primary Insurance city missing
+ . ;          IB286 - Secondary Insurance city missing
+ . ;          IB287 - Tertiary Insurance city missing
+ . I $$NOPUNCT^IBCEF($P(SFA,U,2),1)="" D   ; city is blank
+ .. ; pat=subscriber and current insurance - address is required
+ .. I +PTREL=1,IBISEQ=$$COBN^IBCEF(IBIFN) D ERR(285) Q
+ .. ; if any part of the address is there, then all fields are required
+ .. I CAS'="" D ERR(285) Q
+ .. Q
+ . ;
+ . ;          IB288 - Primary Insurance state missing
+ . ;          IB289 - Secondary Insurance state missing
+ . ;          IB290 - Tertiary Insurance state missing
+ . I $$NOPUNCT^IBCEF($P(SFA,U,3),1)="" D   ; state is blank
+ .. ; pat=subscriber and current insurance - address is required
+ .. I +PTREL=1,IBISEQ=$$COBN^IBCEF(IBIFN) D ERR(288) Q
+ .. ; if any part of the address is there, then all fields are required
+ .. I CAS'="" D ERR(288) Q
+ .. Q
+ . ;
+ . ;          IB291 - Primary Insurance zipcode missing
+ . ;          IB292 - Secondary Insurance zipcode missing
+ . ;          IB293 - Tertiary Insurance zipcode missing
+ . I $$NOPUNCT^IBCEF($P(SFA,U,4),1)="" D   ; zipcode is blank
+ .. ; pat=subscriber and current insurance - address is required
+ .. I +PTREL=1,IBISEQ=$$COBN^IBCEF(IBIFN) D ERR(291) Q
+ .. ; if any part of the address is there, then all fields are required
+ .. I CAS'="" D ERR(291) Q
+ .. Q
+ . ;
+ . Q
+ ;
+ ; esg - IB*2*371 - check patient address fields
+ K ^UTILITY("VAPA",$J)
+ ;
+ S IBFOR=0                              ; foreign address flag
+ S IBC=+$$PTADDR^IBCEF(IBIFN,25)        ; country code ien
+ I IBC D
+ . N CODE
+ . S CODE=$$GET1^DIQ(779.004,IBC,.01)   ; .01 code field file 779.004
+ . I CODE'="",CODE'="USA" S IBFOR=1     ; foreign country exists
+ . Q
+ ;
+ I $$NOPUNCT^IBCEF($$PTADDR^IBCEF(IBIFN,1),1)="" S IBER=IBER_"IB269;"
+ I $$NOPUNCT^IBCEF($$PTADDR^IBCEF(IBIFN,4),1)="" S IBER=IBER_"IB270;"
+ I $$NOPUNCT^IBCEF($$PTADDR^IBCEF(IBIFN,5),1)="",'IBFOR S IBER=IBER_"IB271;"
+ I $$NOPUNCT^IBCEF($$PTADDR^IBCEF(IBIFN,11),1)="",'IBFOR S IBER=IBER_"IB272;"
+ K ^UTILITY("VAPA",$J)
+ ;
+ D PAYERADD^IBCBB0(IBIFN)     ; check the payer addresses
+ ;
+ ; esg - 9/20/07 - IB patch 371 - prevent EDI transmission for 3 payer
+ ;       claims for all but the first payer.  To be removed when Emdeon
+ ;       and FSC are able to deal with these.
+ ;
+ I +$G(^DGCR(399,IBIFN,"I2")),+$G(^DGCR(399,IBIFN,"I3")),$$TXMT^IBCEF4(IBIFN) D
+ . ; for MRA request claims, make sure the MRA secondary claim is forced to print
+ . I $$REQMRA^IBEFUNC(IBIFN) D  Q
+ .. I '$P($G(^DGCR(399,IBIFN,"TX")),U,9) S IBER=IBER_"IB146;"
+ .. Q
+ . ;
+ . I $$COBN^IBCEF(IBIFN)=1 Q   ; primary payer sequence claims are OK
+ . ;
+ . ; But claims with a payer sequence of 2 or 3 need to print locally
+ . S IBER=IBER_"IB147;"
+ . I '$P(IDDATA,U,1) D  ; birth date missing
+ .. S IBERRNO=220+IBISEQ
+ .. S IBER=IBER_"IB"_IBERRNO_";"
+ . I "^M^F^"'[(U_$P(IDDATA,U,2)_U) D  ; sex missing
+ .. S IBERRNO=260+IBISEQ
+ .. S IBER=IBER_"IB"_IBERRNO_";"
  . Q
+ ;
 …
  Q ($P(IBND0,U,24)_$P($G(^DGCR(399.1,+$P(IBND0,U,25),0)),U,2)_$P(IBND0,U,26))
+ ;
-ERR(Z) ; update IBER variable from the above insurance checks
- ; Z is the IB error code# for the primary insurance error
- N IBERRNO
- S IBERRNO="IB"_(Z+IBISEQ-1)
- I IBER[IBERRNO Q
- S IBER=IBER_IBERRNO_";"
+ Q
+ ;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB1.m

-              r628
+              r636
 IBCBB1 ;ALB/AAS - CONTINUATION OF EDIT CHECK ROUTINE ;2-NOV-89
  ;;2.0;INTEGRATED BILLING;**27,52,80,93,106,51,151,148,153,137,232,280,155,320,343,349,363,371,395**;21-MAR-94;Build 3
+ ;;2.0;INTEGRATED BILLING;**27,52,80,93,106,51,151,148,153,137,232,280,155,320,343,349,363**;21-MAR-94;Build 35
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
  S IBTFY=$$FY^IBOUTL(IBTDT)
+ ;
+ ;Statement crosses fiscal years
+ ;I IBTFY'=IBFFY S IBER=IBER_"IB047;"
+ ;
+ ;Statement crosses calendar years
+ ;I $E(IBTDT,1,3)'=$E(IBFDT,1,3) S IBER=IBER_"IB046;"
+ ;
  ;Total Charges
  I +IBTC'>0!(+IBTC'=IBTC) S IBER=IBER_"IB064;"
 …
  I IBAU]"",'$D(^VA(200,IBAU,0)) S IBER=IBER_"IB041;"
+ ;
+ ;Bill exists and not already new bill
+ ;I $S('$D(^PRCA(430,IBIFN,0)):1,$P($P(^PRCA(430,IBIFN,0),"^"),"-",2)'=IBBNO:1,1:0) S IBER=IBER_"IB056;"
+ ;I $P($$BN^PRCAFN(IBIFN),"-",2)'=IBBNO S IBER=IBER_"IB056;"
+ ;I IBER="",$P(^PRCA(430,IBIFN,0),"^",8)=$O(^PRCA(430.3,"AC",104,"")) S IBER=IBER_"IB040;"
  I IBER="",+$$STA^PRCAFN(IBIFN)=104 S IBER=IBER_"IB040;"
  ; If ins bill, must have valid COB sequence
 …
  ; Check NPIs
  D NPICHK^IBCBB11
+ ;
- ; Check multiple rx NPIs
- D RXNPI^IBCBB11(IBIFN)
+ ;
  ; Check taxonomies
 …
  ... S Q0=0 F  S Q0=$O(IBID(1,FUNCTION,Q0)) Q:'Q0  I $P(IBID(1,FUNCTION,Q0),U,9)=+Z S IBOK=1 Q
  ... I 'IBOK S IBER=IBER_$S(IBINS=1:"IB236;",IBINS=2:"IB237;",IBINS=3:"IB238;",1:"")
+ ;
+ D PRIIDCHK^IBCBB11
+ . I $$TXMT^IBCEF4(IBIFN) D
+ .. D F^IBCEF("N-ALL ATT/REND PROV SSN/EI","IBZ",,IBIFN)
+ .. I $P(IBZ,U,3)=""&($P(IBZ,U,4)="") S IBER=IBER_"IB321;" ; SSN/IEN required for rend/att
+ ;
  N IBM,IBM1
 …
  F Z=0:1:2 S Z0=$O(Z(Z)) Q:'Z0  I Z0'=(Z+1) S IBER=IBER_"IB322;" Q
  K Z
+ ; HD64676  IB*2*371 - OK for payer sequence to be blank when the Rate
+ ;    Type is either Interagency or Sharing Agreement
+ I $P($G(^DGCR(399,IBIFN,0)),U,21)="",$P($G(^DGCR(399,IBIFN,0)),U,7)'=4,$P($G(^DGCR(399,IBIFN,0)),U,7)'=9 S IBER=IBER_"IB323;"
+ I $P($G(^DGCR(399,IBIFN,0)),U,21)="" S IBER=IBER_"IB323;"
  K IBXDATA D F^IBCEF("N-PROCEDURE CODING METHD",,,IBIFN)
  ; Coding method should agree with types of procedure codes
 …
+ ;
  D VALNDC^IBCBB11(IBIFN,DFN)  ;validate NDC#
+ ;
  ;Build AR array if no errors and MRA not needed or already rec'd
  I IBER="",$S($$NEEDMRA^IBEFUNC(IBIFN)!($$REQMRA^IBEFUNC(IBIFN)):0,1:1) D ARRAY

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB11.m

-              r628
+              r636
 IBCBB11 ;ALB/AAS - CONTINUATION OF EDIT CHECK ROUTINE ;12 Jun 2006  3:45 PM
  ;;2.0;INTEGRATED BILLING;**51,343,363,371,395,392**;21-MAR-94;Build 2
+ ;;2.0;INTEGRATED BILLING;**51,343,363**;21-MAR-94;Build 35
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
  S IBTAXS=$$PROVTAX^IBCEF73A(IBIFN,.IBNOTAX)
  I $L(IBNOTAX) F Z=1:1:$L(IBNOTAX,U) D
+ . ; Only Referring, Rendering and Attending are currently sent to the payer
+ . I IBTAXREQ,"134"[$P(IBNOTAX,U,Z) S IBER=IBER_"IB"_(250+$P(IBNOTAX,U,Z))_";" Q  ; If required, set error
+ . I IBTAXREQ S IBER=IBER_"IB"_(250+$P(IBNOTAX,U,Z))_";" Q  ; If required, set error
  . D WARN("Taxonomy for the "_$P("referring^operating^rendering^attending^supervising^^^^other",U,$P(IBNOTAX,U,Z))_" provider has no value")  ; Else, set warning
  ; Check organizations
 …
  S IBTAXS=$$ORGTAX^IBCEF73A(IBIFN,.IBNOTAX)
  I $L(IBNOTAX) F Z=1:1:$L(IBNOTAX,U) D
+ . ; These are not currently sent to the payer so no errors yet
+ . ; I IBTAXREQ S IBER=IBER_"IB"_(164+$P(IBNOTAX,U,Z))_";" Q  ; If required, set error
+ . I IBTAXREQ S IBER=IBER_"IB"_(164+$P(IBNOTAX,U,Z))_";" Q  ; If required, set error
  . ; PRXM/KJH - Changed descriptions.
  . D WARN("Taxonomy for the "_$P("Division^Non-VA Service Facility^Billing Provider",U,$P(IBNOTAX,U,Z))_" has no value")  ; Else, set warning
+ Q
+ ;
 VALNDC(IBIFN,IBDFN) ; IB*2*363 - validate NDC# between PRESCRIPTION file (#52)
+VALNDC(IBIFN,IBDFN) ; IB*2*363 - validate NDC# between PRESCRIPTION file (#52)
  ; and IB BILL/CLAIMS PRESCRIPTION REFILL file (#362.4)
  ; input - IBIFN = internal entry number of the billing record in the BILL/CLAIMS file (#399)
 …
  S IBX=0 F  S IBX=$O(IBRXCOL(IBX)) Q:'IBX  D WARN("NDC# on Bill does not equal the NDC# on Rx "_IBRXCOL(IBX))
+ Q
+ ;
-PRIIDCHK ; Check for required Pimarary ID (SSN/EIN)
- ; If the provider is on the claim, he must have one
+ ;
- N IBI,IBZ
- I $$TXMT^IBCEF4(IBIFN) D
- . D F^IBCEF("N-ALL ATT/REND PROV SSN/EI","IBZ",,IBIFN)
- . S IBI="" F  S IBI=$O(^DGCR(399,IBIFN,"PRV","B",IBI)) Q:IBI=""  D
- .. I $P(IBZ,U,IBI)="" S IBER=IBER_$S(IBI=1:"IB151;",IBI=2:"IB152;",IBI=3!(IBI=4):"IB321;",IBI=5:"IB153;",IBI=9:"IB154;",1:"")
+ Q
+ ;
-RXNPI(IBIFN) ; check for multiple pharmacy npi's on the same bill
- N IBORG,IBRXNPI,IBX,IBY
- S IBORG=$$RXSITE^IBCEF73A(IBIFN,.IBORG)
- S IBX=0 F  S IBX=$O(IBORG(IBX)) Q:'IBX  S IBY=0 F  S IBY=$O(IBORG(IBX,IBY)) Q:'IBY  S IBRXNPI(+IBORG(IBX,IBY))=""
- S (IBX,IBY)=0 F  S IBX=$O(IBRXNPI(IBX)) Q:'IBX  S IBY=IBY+1
- I IBY>1 D WARN("Bill has prescriptions resulting from "_IBY_" different NPI locations")
+ Q

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB2.m

-              r628
+              r636
 IBCBB2 ;ALB/ARH - CONTINUATION OF EDIT CHECKS ROUTINE (CMS-1500) ;04/14/92
  ;;2.0;INTEGRATED BILLING;**51,137,210,245,232,296,320,349,371**;21-MAR-94;Build 57
+ ;;2.0;INTEGRATED BILLING;**51,137,210,245,232,296,320,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
+ ;
 EN ;
  N IBI,IBJ,IBN,IBY,IBDX,IBDXO,IBDXL,IBCPT,IBCPTL,IBOLAB,Z,IBXSAVE,IBLOC,IBTX,IBPS,IBSP,IBLCT,IBNVFLG,IBU3
+ N IBI,IBJ,IBN,IBY,IBDX,IBDXO,IBDXL,IBCPT,IBCPTL,IBOLAB,Z,IBXSAVE,IBLOC,IBTX,IBPS,IBSP,IBLCT
  I '$D(IBER) S IBER=""
  S IBTX=$$TXMT^IBCEF4(IBIFN)
+ ;
+ ; Warn if no group provider id (MCRWNR is a default)
+ ; I '$$WNRBILL^IBEFUNC(IBIFN) D
+ ; . S Z=$P($G(^DGCR(399,IBIFN,"M1")),U,$$COBN^IBCEF(IBIFN)+1)
+ ; . I Z="" D WARN^IBCBB11("No group prov # for the current ins co - site tax id will be used")
  ; Max 4 modifiers per CPT code allowed before warning
  K IBXDATA
 …
  ; CPT procs must be associated with a dx, must have a defined provider
  S (IBLOC,IBN,IBI,IBY)=0 F  S IBI=$O(^DGCR(399,IBIFN,"CP",IBI)) Q:IBI'?1N.N  S IBCPT=^(IBI,0) D  I +IBY S IBN=1
+ . ;I IBER'["IB089",$P(IBCPT,U,10)=7,$S('$P(IBCPT,U,16):1,1:$P(IBCPT,U,16)#15) S IBER=IBER_"IB089;" ;anesthesia needs minutes in multiple of 15
  . I 'IBLOC,$P(IBCPT,U,15)'="",IBTX S Z="At least 1 charge has local box 24K data that will not be transmitted - " S IBLOC=1 D WARN^IBCBB11(Z) S Z="  This data will only print locally" D WARN^IBCBB11(Z)
  . I $P(IBCPT,U)'["ICPT(" S:IBER'["IB092" IBER=IBER_"IB092;" Q
  . S IBY=1 F IBJ=11:1:14 I +$P(IBCPT,"^",IBJ) S IBCPTL(+$P(IBCPT,"^",IBJ))="",IBY=0
+ . ;I '$P(IBCPT,U,18) S:IBER'["IB094;" IBER=IBER_"IB094;" Q
  I +IBN S IBER=IBER_"IB072;"
+ ;
 …
  S Z=$$EVENT^IBCF22(IBIFN,.IBXSAVE,.IBI)
  I IBI S IBER=IBER_"IB099;"
+ ;
- ; esg - 6/6/07 - warning if missing non-VA care type for outside facility
- S IBNVFLG=0
- I $P(IBNDU2,U,10),'$P(IBNDU2,U,11) D WARN^IBCBB11("Non-VA facility indicated, but the Non-VA Care Type field is not defined") S IBNVFLG=1
+ ;
  ; unit/charge limits
  K IBXDATA
 …
  .. I $P(IBXDATA(IBI),U,14),"24"'[$P(IBNDU2,U,11) D WARN^IBCBB11("Outside lab charges exist on a non-lab NON-VA bill")
  . I '$P(IBNDU2,U,11),$P(IBXDATA(IBI),U,11) D WARN^IBCBB11("Purchased service amounts are invalid unless this is a NON-VA bill")
- . I IBNVFLG,'$P(IBXDATA(IBI),U,11) D WARN^IBCBB11("Non-VA facility indicated, but no purchased service charge on line# "_IBI)
  . I $D(IBXDATA(IBI,"A")) S IBER=IBER_"IB310;" Q
  . I $D(IBXDATA(IBI,"ARX")),IBER'["311;" S IBER=IBER_"IB311;" Q
 …
  . I IBER'["IB090",$P(IBXDATA(IBI),U,9)'<10000 S IBER=IBER_"IB090;"
  . I '($P(IBXDATA(IBI),U,9)*$P(IBXDATA(IBI),U,8)),$$COBN^IBCEF(IBIFN)'>1 S Z="Procedure "_$P(IBXDATA(IBI),U,5)_" has a 0-charge and will not be transmitted" D WARN^IBCBB11(Z)
+ . I $G(IBXDATA(IBI,"AUX"))'="",'$G(IBSP(1)),+IBSP'=35,$TR($P(IBXDATA(IBI,"AUX"),U,4,6)_$P(IBXDATA(IBI,"AUX"),U,2),U)'="" S IBSP(1)=1
  I IBTX,IBLCT>50 D
  . I '$$REQMRA^IBEFUNC(IBIFN) S IBER=IBER_"IB308;" Q
  . I '$P(IBNDTX,U,9) S IBER=IBER_"IB325;"
+ S IBU3=$P($G(^DGCR(399,IBIFN,"U3")),U,4,7) I $TR(IBU3,U)'="" D
+ .I +IBSP'=35 D WARN^IBCBB11("Chiropractic service details only valid if provider specialty is '35'")
+ .I $P(IBU3,U,2)="" S IBER=IBER_"IB137;"
+ .I $P(IBU3,U,4)="" S IBER=IBER_"IB138;" Q
+ .I $P(IBU3,U,3)="","AM"[$P(IBU3,U,4) S IBER=IBER_"IB139;"
+ .Q
+ I $G(IBSP(1)) D WARN^IBCBB11("Chiropractic service details only valid if provider specialty is '35'")
  I IBPS'="" D WARN^IBCBB11("NON-VA facility indicated, but no purchased service charge on line item"_$S(IBPS[",":"s",1:"")_" #"_IBPS)
  I $P(IBNDU2,U,11),$P(IBNDU2,U,11)=4,IBOLAB>1 D WARN^IBCBB11("For proper payment, you must bill each outside lab on a separate claim form")

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB3.m

-              r628
+              r636
 IBCBB3 ;ALB/TMP - CONTINUATION OF EDIT CHECKS ROUTINE (MEDICARE) ;06/23/98
  ;;2.0;INTEGRATED BILLING;**51,137,155,349,371,377**;21-MAR-94;Build 23
+ ;;2.0;INTEGRATED BILLING;**51,137,155,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
  I $G(IBXDATA)="",IBFT=3 D  Q:IBQUIT
  . N Z
  . I "^11^18^"[(U_IBTOB12_U) S IBQUIT=$$IBER(.IBER,231) Q
+ . I "^11^18^"[(U_IBTOB12_U) S IBQUIT=$$IBER^IBCBB3(.IBER,231) Q
  . I $$INPAT^IBCEF(IBIFN,1) S Z="Admitting Diagnosis may be required by payer, please verify" D WARN^IBCBB11(Z)
+ ;
 …
  S IBOK=1,Z=0,IBZP=U F  S Z=$O(Z(Z)) Q:'Z  S:$S($P($G(Z(Z,1)),U,3)["VA(200":1,1:0) IBZP=IBZP_+$P(Z(Z,1),U,3)_U
  D ALLPROC^IBCVA1(IBIFN,.IBZP1)
  S Z=0 F  S Z=$O(IBZP1(Z)) Q:'Z  I $P(IBZP1(Z),U,18),IBZP'[(U_$P(IBZP1(Z),U,18)_U) S IBOK=0 Q
+ S Z=0 F  S Z=$O(IBZP1(Z)) Q:'Z  I $P(IBZP1(Z),U,18),(U_$P(IBZP1(Z),U,18)_U)'[IBZP S IBOK=0 Q
  I 'IBOK D WARN^IBCBB11("At least one provider on a procedure does not match your "_$S(IBFT=2:"render",1:"attend")_"ing or operating provider")
  I IBFT=2 D EN^IBCBB2
 …
 PARTA ; MEDICARE specific edit checks for PART A claims (UB-04 formats)
+ ;
  N IBI,IBJ,IBX,IBCTYP,VADM,VAPA,IBSTOP,IBDXC,IBDXARY,IBPR,IBLABS,REQMRA
+ N IBI,IBJ,IBX,IBCTYP,VADM,VAPA,IBSTOP,IBDXC,IBDXARY,IBPR,IBLABS
  N IBS,IBTUNIT,IBCAGE,IBREV1,IBOCCS,IBOCSDT,IBVALCD,IBOCCD,IBNOPR
  N IBCCARY1,IBPATST,IBZADMIT,IBZDISCH,IBXIEN,IBXERR,IBXDATA,IBOCSP
 …
  ;              procedure
+ ;
- S REQMRA=$$REQMRA^IBEFUNC(IBIFN)
  S (IBNOPR,IBI)=0
  F  S IBI=$O(IBXDATA(IBI)) Q:'IBI  D
- . I REQMRA D GYMODCHK(IBXDATA(IBI))      ; IB*2*377 GY modifier check
  . S IBJ=$P(IBXDATA(IBI),U),IBECAT=""
  . I 'IBNOPR D
 …
  . ;    to be sent to MEDICARE for an MRA
  . D NONMCR(.IBPR,.IBLABS) ; Remove Oxygen, labs, influenza shots
+ . ;I $O(IBPR(""))="" D
  . I $G(IBLABS) D WARN^IBCBB11("The only possible billable procedures on this bill are labs -"),WARN^IBCBB11(" Please verify that MEDICARE does not reimburse these labs at 100%") Q
  . I $O(IBPR(""))="" D
 …
  D DEM^VADPT
  I $P(VADM(5),U)'="M",$P(VADM(5),U)'="F" S IBQUIT=$$IBER(.IBER,124) Q:IBQUIT
+ ;
- ; esg - 10/17/07 - patch 371
- ; For Part A replacement MRA request claims, make sure
- ; the Medicare ICN/DCN number is present and also text in FL-80.
- I $$REQMRA^IBEFUNC(IBIFN),$F(".137.138.117.118.","."_IBTOB_".") D  Q:IBQUIT
- . N IBZ,FL80TXT
- . D F^IBCEF("N-CURR INS FORM LOC 64","IBZ",,IBIFN)  ; see CI3-11
- . I IBZ="" S IBQUIT=$$IBER(.IBER,205) Q:IBQUIT      ; missing ICN/DCN
- . S FL80TXT=$P($G(^DGCR(399,IBIFN,"UF2")),U,3)
- . I FL80TXT="" S IBQUIT=$$IBER(.IBER,206) Q:IBQUIT  ; missing FL80 text
- . Q
+ ;
  D ^IBCBB4
 …
  F Z=77:1:85 S Z0="E13"_Z K IBPR(Z0)
  ; Labs
+ ;S Z="80000" F  S Z=$O(IBPR(Z)) Q:Z'?1"8"4N  K IBPR(Z) S IBLABS=1
  S Z="80000" F  S Z=$O(IBPR(Z)) Q:Z'?1"8"4N  S IBLABS=1
  ; Flu shots
 …
  Q IB
+ ;
-GYMODCHK(Z) ; GY modifier check procedure.  IB*2*377 - 2/4/08
- ; Z is the IBXDATA(IBI) service line EDI
- N MODS
- I IBER["IB123" Q     ; error already found
- S MODS=$P(Z,U,9)     ; list of modifiers separated by commas
- I MODS'["GY" Q       ; GY modifier not here on this line item
- I $P(Z,U,6) Q        ; non-covered charges exist on this line item
- S IBQUIT=$$IBER(.IBER,123)
-GYMODX ;
+ Q
+ ;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB5.m

-              r628
+              r636
 IBCBB5 ;ALB/BGA - CONT OF MEDICARE EDIT CHECKS ;08/12/98
  ;;2.0;INTEGRATED BILLING;**51,137,371**;21-MAR-94;Build 57
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**51,137**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified
+ ;
  D F^IBCEF("N-ADMISSION DATE","IBZADMIT",,IBIFN)
 …
  S IBI=0 F  S IBI=$O(IBXSAVE("OCCS",IBI)) Q:'IBI  D
  . N IBOCSDT,IBOCSDT1,Z
  . S IBOCSDT=$P(IBXSAVE("OCCS",IBI),U,2),IBOCSDT1=$P(IBXSAVE("OCCS",IBI),U,3),IBOCCS=$P(IBXSAVE("OCCS",IBI),U)
+ . S IBOCSDT=$P(IBXSAVE("OCCS",IBI),U,2),IBOCSDT1=$P(IBXSAVE("OCCS",IBI),U,4),IBOCCS=$P(IBXSAVE("OCCS",IBI),U)
  . S IBOCSP(IBOCCS,$O(IBOCSP(IBOCCS,""),-1)+1)=IBXSAVE("OCCS",IBI)
- . ; Occurrence Code End dates must be > start date and are required for OCCURANCE SPANS
- . I 'IBOCSDT1 S IBER=IBER_"IB155;" Q
- . I IBOCSDT1<IBOCSDT S IBER=IBER_"IB150;" Q
+ ;
  S IBI=0 F  S IBI=$O(IBXSAVE("OCC",IBI)) Q:'IBI  D
 …
  S IBX=0
  F  S IBX=$O(IBXDATA(IBX)) Q:'IBX  D  Q:IBQUIT
- . I '$D(IBVALCD($P(IBXDATA(IBX),U))) S IBVALCD($P(IBXDATA(IBX),U))=$P(IBXDATA(IBX),U,2)
  . ; value code 01 must have a value>0
+ . I $P(IBXDATA(IBX),U)="01",IBER'["134;",$P(IBXDATA(IBX),U,2)'>0 S IBQUIT=$$IBER^IBCBB3(.IBER,134) Q
+ . I $P(IBXDATA(IBX),U)="01",IBER'["134;",$P(IBXDATA(IBX),U,2)'>0 S IBQUIT=$$IBER^IBCBB3(.IBER,134)
+ . Q:IBQUIT
  . ; value code 02 must have a value=0
  . I $P(IBXDATA(IBX),U)="02",IBER'["135;",+$P(IBXDATA(IBX),U,2)'=0 S IBQUIT=$$IBER^IBCBB3(.IBER,135) Q
+ . I $P(IBXDATA(IBX),U)="02",IBER'["135;",+$P(IBXDATA(IBX),U,2)'=0 S IBQUIT=$$IBER^IBCBB3(.IBER,135)
  . ; code^amount^dollar amt flag (1=amt,0=quantity)
+ . I $P(IBXDATA(IBX),U,2)="",IBER'["157;" S IBQUIT=$$IBER^IBCBB3(.IBER,157) Q
+ . I '$$CHK^IBCVC($P(IBXDATA(IBX),U,4),$P(IBXDATA(IBX),U,2)),IBER'["158;" S IBQUIT=$$IBER^IBCBB3(.IBER,158) Q
+ . Q:IBQUIT
+ . I '$D(IBVALCD($P(IBXDATA(IBX),U))) S IBVALCD($P(IBXDATA(IBX),U))=$P(IBXDATA(IBX),U,2) Q
+ ; Must have value code 01 or 02 for TOB 11X, 18X, 21X - default it
+ ;I '$D(IBVALCD("01")),'$D(IBVALCD("02")),$S(IBTOB12="11":1,IBTOB12="18":1,1:IBTOB12="21") S IBQUIT=$$IBER^IBCBB3(.IBER,132)
+ ;
  Q:IBQUIT

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB9.m

-              r628
+              r636
 IBCBB9 ;ALB/BGA MEDICARE PART B EDIT CHECKS ;10/15/98
  ;;2.0;INTEGRATED BILLING;**51,137,155,349,371**;21-MAR-94;Build 57
+ ;;2.0;INTEGRATED BILLING;**51,137,155,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
  I $S($G(IBXDATA)="":1,$E($P(IBXDATA,U))=" "!($E($P(IBXDATA,U))'?1A):1,$E($P(IBXDATA,U,2))=" "!($E($P(IBXDATA,U,2))'?1A):1,1:0) S IBQUIT=$$IBER^IBCBB3(.IBER,300) Q:IBQUIT
+ ;
+ ; First char of the pat's address and city must not be a space
+ K IBXDATA D F^IBCEF("N-PATIENT STREET ADDRESS LN 1",,,IBIFN)
+ I $G(IBXDATA)=""!($E($G(IBXDATA))=" ") S IBQUIT=$$IBER^IBCBB3(.IBER,302) Q:IBQUIT
+ ;
+ K IBXDATA D F^IBCEF("N-PATIENT CITY",,,IBIFN)
+ I $G(IBXDATA)=""!($E($G(IBXDATA))=" ") S IBQUIT=$$IBER^IBCBB3(.IBER,302) Q:IBQUIT
+ ;
  ; Must be a valid HIC #
  I '$$VALID^IBCBB8(IBIFN) S IBQUIT=$$IBER^IBCBB3(.IBER,215) Q:IBQUIT

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCC1.m

-              r628
+              r636
 IBCC1 ;ALB/MJB - CANCEL THIRD PARTY BILL ;10-OCT-94
  ;;2.0;INTEGRATED BILLING;**19,95,160,159,320,347,377**;21-MAR-94;Build 23
+IBCC1 ;ALB/MJB - CANCEL UB-82 THIRD PARTY BILL ;10-OCT-94
+ ;;2.0;INTEGRATED BILLING;**19,95,160,159,320,347**;21-MAR-94;Build 24
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 RNB ; -- Add a reason not billable to claims tracking
  N X,Y,DIC,DIE,I,J,DA,DR,IBTYP,IBTRE,IB,IBAPPT,IBDT,IBTALK,IBCODE,IBTRED,IBTSAV,FILL,IBRX,IBDATA,IBD,IBDT,IBQUIT,IBPRO,IBDD
- N ZT,TCNT,CNT
  Q:'$G(IBIFN)
  S IB(0)=$G(^DGCR(399,IBIFN,0)),IBTYP=$P(IB(0),"^",5),IBQUIT=0
  I '$D(DFN) S DFN=$P(IB(0),"^",2)
- KILL ^TMP($J,"IBCC1")
+ ;
  ; -- is inpt find entry in dgpm, then in ibt(356, s da=ibtre then edit
 …
  .S DGPM=$O(^DGPM("APTT1",DFN,DATE,0)) ; double check for asih
  .I DGPM S (IBTRE,IBTSAV)=$O(^IBT(356,"AD",DGPM,0))
  .I $G(IBTRE) D CTSET(IBTRE)
+ .I $G(IBTRE) D RNBEDIT
  .Q:IBQUIT
  .;
 …
  .S DATE=$P(IB(0),"^",3),DFN=$P(IB(0),"^",2)
  .S IBDT=(DATE-.25) F  S IBDT=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT)) Q:'IBDT!(IBDT>(DATE+.24))  D
  ..S IBTRE=0 F  S IBTRE=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT,IBTRE)) Q:IBTRE=""!(IBQUIT)  D:$G(IBTSAV)'=IBTRE CTSET(IBTRE)
+ ..S IBTRE=0 F  S IBTRE=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT,IBTRE)) Q:IBTRE=""!(IBQUIT)  D:$G(IBTSAV)'=IBTRE RNBEDIT
  .Q
+ ;
 …
  .S IBAPPT=0 F  S IBAPPT=$O(^DGCR(399,IBIFN,"OP",IBAPPT)) Q:'IBAPPT!(IBQUIT)  D
  ..S IBDT=(IBAPPT-.01) F  S IBDT=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT)) Q:'IBDT!(IBDT>(IBAPPT+.24))  D
  ...S IBTRE=0 F  S IBTRE=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT,IBTRE)) Q:IBTRE=""!(IBQUIT)  D CTSET(IBTRE)
+ ...S IBTRE=0 F  S IBTRE=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT,IBTRE)) Q:IBTRE=""!(IBQUIT)  D RNBEDIT
  .Q
+ ;
 …
  .I '$G(IBRX) S DIC=52,DIC(0)="BO",X=$P(IBDATA,"^",1) D DIC^PSODI(52,.DIC,X) S IBRX=+Y K DIC,X,Y Q:IBRX=-1
  .S FILL="" F  S FILL=$O(^IBT(356,"ARXFL",IBRX,FILL)) Q:FILL=""!(IBQUIT)  D
  ..S IBTRE=0 F  S IBTRE=$O(^IBT(356,"ARXFL",IBRX,FILL,IBTRE)) Q:'IBTRE!(IBQUIT)  I $P(^IBT(356,+IBTRE,0),"^",6)=IBDT D CTSET(IBTRE)
+ ..S IBTRE=0 F  S IBTRE=$O(^IBT(356,"ARXFL",IBRX,FILL,IBTRE)) Q:'IBTRE!(IBQUIT)  I $P(^IBT(356,+IBTRE,0),"^",6)=IBDT D RNBEDIT
+ ;
 PRO ; -- find prosthetics on bill
 …
  .S IBDATA=$G(^IBA(362.5,IBD,0)),IBPRO=$P(IBDATA,"^",4)
  .Q:'$G(IBPRO)
+ .S IBTRE=0 F  S IBTRE=$O(^IBT(356,"APRO",+IBPRO,IBTRE)) Q:'IBTRE!(IBQUIT)  D CTSET(IBTRE)
+ ;
+ ; ----- Finished with the gathering of the CT data entries -----
+ ;
+ ; count up the total number of CT entries recorded in the scratch global
+ S ZT="",TCNT=0
+ F  S ZT=$O(^TMP($J,"IBCC1",ZT)) Q:ZT=""  S IBTRE=0 F  S IBTRE=$O(^TMP($J,"IBCC1",ZT,IBTRE)) Q:'IBTRE  S TCNT=TCNT+1
+ ;
+ ; loop thru all of the associated CT entries and call the RNBEDIT procedure for each one
+ S ZT="",CNT=0
+ F  S ZT=$O(^TMP($J,"IBCC1",ZT)) Q:ZT=""!IBQUIT  D  Q:IBQUIT
+ . S IBTRE=0 F  S IBTRE=$O(^TMP($J,"IBCC1",ZT,IBTRE)) Q:'IBTRE!IBQUIT  S CNT=CNT+1 D RNBEDIT(IBTRE,ZT,TCNT,CNT)
+ . Q
+ ;
+ ; clean-up the scratch global when completed
+ KILL ^TMP($J,"IBCC1")
+ .S IBTRE=0 F  S IBTRE=$O(^IBT(356,"APRO",+IBPRO,IBTRE)) Q:'IBTRE!(IBQUIT)  D RNBEDIT
+ Q
+ ;
+CTSET(IBTRE) ; procedure to store this CT entry in the scratch global
+ Q:'$G(IBTRE)
+ S ^TMP($J,"IBCC1",$$TYPE(IBTRE),IBTRE)=""
+CTSETX ;
+ Q
+ ;
+RNBEDIT(IBTRE,CTTYPE,TCNT,CNT) ; CT entry display and capture RNB data and additional comment data
+RNBEDIT ;
  Q:IBQUIT
+ I '$D(IBTALK) D
+ . N CTZ
+ . W !!,"Since you have canceled this bill, you may enter a Reason Not Billable and"
+ . W !,"an Additional Comment into Claims Tracking."
+ . W !,"This will take the care off of the UNBILLED lists."
+ . I TCNT=1 S CTZ="Note:  There is 1 associated Claims Tracking entry."
+ . E  S CTZ="Note:  There are "_TCNT_" associated Claims Tracking entries."
+ . W !!,CTZ
+ . Q
+ ;
+ W:'$D(IBTALK) !!,"Since you have canceled this bill, you may enter a Reason Not Billable",!,"into Claims Tracking.  This will take the care off of the UNBILLED lists"
  S IBTALK=1
+ ;
+ N %,IBTRED,IBTRED1 S IBTRED=$G(^IBT(356,IBTRE,0)),IBTRED1=$G(^IBT(356,IBTRE,1))
+ ;
+ W !!,"Claims Tracking Entry [",CNT," of ",TCNT,"]"
+ W !?7,"Entry ID#: ",+IBTRED
+ W !?12,"Type: ",$$EXPAND^IBTRE(356,.18,$P(IBTRED,U,18))
+ ;
+ I CTTYPE=1 D     ; inpatient admission or scheduled admission
+ . W !?2,"Admission Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P")
+ . Q
+ ;
+ I CTTYPE=2 D     ; outpatient visit
+ . N IBOE,IBOE0
+ . W !?6,"Visit Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P")
+ . S IBOE=+$P(IBTRED,U,4),IBOE0=$$SCE^IBSDU(IBOE)
+ . W !?10,"Clinic: ",$$GET1^DIQ(44,+$P(IBOE0,U,4)_",",.01)
+ . Q
+ ;
+ I CTTYPE=3 D     ; prescription refill
+ . N PSONTALK,PSOTMP,X
+ . S PSONTALK=1
+ . S X=+$P(IBTRED,U,8)_U_+$P(IBTRED,U,10) D EN^PSOCPVW
+ . ;if refill was deleted and EN^PSOCPVW doesn't return any data use IB API
+ . I '$D(PSOTMP) D PSOCPVW^IBNCPDPC(+$P(IBTRED,U,2),+$P(IBTRED,U,8),.PSOTMP)
+ . W !?3,"Prescription#: ",$G(PSOTMP(52,+$P(IBTRED,U,8),.01,"E"))
+ . I '$P(IBTRED,U,10) W !?7,"Fill Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P")
+ . I $P(IBTRED,U,10) W !?5,"Refill Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P")
+ . W !?12,"Drug: ",$G(PSOTMP(52,+$P(IBTRED,U,8),6,"E"))
+ . Q
+ ;
+ I CTTYPE=4 D     ; prosthetic item
+ . N IBDA,IBRMPR
+ . S IBDA=$P(IBTRED,U,9)
+ . D PRODATA^IBTUTL1(IBDA)
+ . W !?3,"Delivery Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P")
+ . W !?12,"Item: ",$G(IBRMPR(660,+IBDA,4,"E"))
+ . W !?5,"Description: ",$G(IBRMPR(660,+IBDA,24,"E"))
+ . Q
+ ;
+ N %,IBTRED S IBTRED=$G(^IBT(356,IBTRE,0))
+ W !!,"Claims Tracking entry: ",+IBTRED,"  ",$$EXPAND^IBTRE(356,.18,$P(IBTRED,"^",18)),"  ",$$FMTE^XLFDT($P(IBTRED,"^",6))
  I $G(IBMCSRNB)'="",$P(IBTRED,U,19) W !," Note:  A Reason Not Billable has been previously entered",!?8,"for this Claims Tracking record."
- I $G(IBMCSCAC)'="",$P(IBTRED1,U,8)'="" W !," Note:  An Additional Comment has been previously entered",!?8,"for this Claims Tracking record."
+ ;
  S DA=IBTRE,DIE="^IBT(356,",DR=".19"
+ I $G(IBMCSRNB)'="" S DR=".19//"_$P(IBMCSRNB,U,2)    ; IB*320 MCS cancel - reason not billable
+ I $G(IBMCSCAC)'="" S DR=DR_";1.08//^S X=IBMCSCAC"   ; IB*377 MCS cancel - additional comment
+ I $G(IBMCSCAC)="" S DR=DR_";1.08"                   ; IB*377 additional comment field SRS 3.3.2.1
+ I $G(IBMCSRNB)'="" S DR=".19//"_$P(IBMCSRNB,U,2)    ; IB*320 MCS cancel
  D ^DIE
+ ;
  ; - if the RNB or additional comment changed, update the user and date/time last edited
  I $P(IBTRED,U,19)'=$P($G(^IBT(356,IBTRE,0)),U,19)!($P(IBTRED1,U,8)'=$P($G(^IBT(356,IBTRE,1)),U,8)) D NOW^%DTC S DR="1.03///"_%_";1.04////"_DUZ D ^DIE
+ ; - if the RNB changed, update the user and date/time last edited
+ I $P(IBTRED,"^",19)'=$P($G(^IBT(356,IBTRE,0)),"^",19) D NOW^%DTC S DR="1.03///"_%_";1.04////"_DUZ D ^DIE
+ ;
  ; $D(Y) indicates an up-arrow exit from the DIE call (??)
  I $D(Y) S DFN=+$P(^IBT(356,IBTRE,0),"^",2) D FIND^IBOHCT(DFN,IBTRE) S IBQUIT=1
+ Q
+ ;
-TYPE(Z) ; function to get the type of claims tracking entry
- ; Z is the ien to file 356
- Q +$P($G(^IBE(356.6,+$P($G(^IBT(356,+Z,0)),U,18),0)),U,3)
+ ;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCCC2.m

r628	r636
1	1	IBCCC2 ;ALB/AAS - CANCEL AND CLONE A BILL - CONTINUED ;6/6/03 9:56am
2		;;2.0;INTEGRATED BILLING;80,106,124,138,51,151,137,161,182,211,245,155,296,320,348,349~~,371;21-MAR-94;Build 57~~
	2	;;2.0;INTEGRATED BILLING;80,106,124,138,51,151,137,161,182,211,245,155,296,320,348,349;21-MAR-94;Build 46
3	3	;;Per VHA Directive 2004-038, this routine should not be modified.
4	4	;
…	…
55	55	U2 F J=1:1:19 I $P(IBND("U2"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U2"),"^",J)=$P(IBND("U2"),"^",J)
56	56	Q
57		U3 F J=1:1:7 I $P(IBND("U3"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U3"),"^",J)=$P(IBND("U3"),"^",J)
	57	U3 F J=1:1:3 I $P(IBND("U3"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U3"),"^",J)=$P(IBND("U3"),"^",J)
58	58	Q
59	59	UF2 F J=1,3 I $P(IBND("UF2"),"^",J)]"" S $P(^DGCR(399,IBIFN,"UF2"),"^",J)=$P(IBND("UF2"),"^",J)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCCC3.m

-              r628
+              r636
 IBCCC3 ;ALB/AAS - CANCEL AND CLONE A BILL - CONTINUED ;25-JAN-90
  ;;2.0;INTEGRATED BILLING;**363,381,389**;21-MAR-94;Build 6
+ ;;2.0;INTEGRATED BILLING;**363,381**;21-MAR-94;Build 1
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
  ... S IBX=$G(^IBA(362.5,IBPIFN,0)) I IBX=""!($P(IBX,U,2)'=IBIFN1) Q
  ... S DIC="^IBA(362.5,",DIC(0)="L",X=$P(IBX,U,1) K DA,DO D FILE^DICN K DA,DO Q:Y'>0
  ... S DR=".02////"_IBIFN_";.04////"_$P(IBX,U,4)_";.05////^S X=$P(IBX,U,5)"
+ ... S DR=".02////"_IBIFN_";.03////"_$P(IBX,U,3)_";.04////"_$P(IBX,U,4)
  ... S DIE=DIC,DA=+Y D ^DIE K DIC,DIE,DA,DO,DR
  K DIE,DIC,DA,DO,DR,X,Y

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE.m

-              r628
+              r636
 IBCE ;ALB/TMP - 837 EDI TRANSMISSION UTILITIES/NIGHTLY JOB ;22-JAN-96
+ ;;2.0;INTEGRATED BILLING;**137,283,296,371**;21-MAR-94;Build 57
+ ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**137,283,296**;21-MAR-94
 EN ; Run all jobs needed for EDI processing nightly
  ; including transmit bills waiting for extract, batches not sent,
 …
+ ;
 RESUB(IB364) ; Manually resubmit bill for transmission (ien file 364 = IB364)
  N DIR,X,Y,IBBTCH,DTOUT,DUOUT,IBIFN,NEW364
+ N DIR,X,Y,IBBTCH,DTOUT,DUOUT
  I '$$MGCHK(1) G RESUBQ
- S IBIFN=+$P($G(^IBA(364,+$G(IB364),0)),U,1) I 'IBIFN G RESUBQ
  S IBBTCH=""
  W ! S DIR(0)="SA^I:IMMEDIATE TRANSMIT;L:TRANSMIT LATER WITH REST OF READY FOR EXTRACT BILLS",DIR("A")="TRANSMIT (I)MMEDIATELY OR (L)ATER?: ",DIR("B")="L"
 …
  D ^DIR K DIR
  I $D(DTOUT)!$D(DUOUT) G RESUBQ
+ ;
+ ; immediate retransmission of claim
+ I Y="I" D  G RESUBQ
+ . S NEW364=$$ADDTBILL^IBCB1(IBIFN)    ; Add a new transmission record
+ . I '$P(NEW364,U,3) D  Q
+ .. S DIR("A",1)="FAILED TO ADD A NEW EDI TRANSMISSION",DIR(0)="EA",DIR("A")="PRESS ENTER TO CONTINUE " W ! D ^DIR K DIR
+ .. Q
+ . ;
+ I Y="I" D  G:'IBBTCH RESUBQ
+ . N Y
  . K ^TMP("IBONE",$J),^TMP("IBSELX",$J),^TMP("IBCE-BATCH",$J)
  . S ^TMP("IBONE",$J,+NEW364)="",^TMP("IBONE",$J)=0,^TMP("IBSELX",$J)=""
+ . S ^TMP("IBONE",$J,IB364)="",^TMP("IBONE",$J)=0,^TMP("IBSELX",$J)=""
  . D ONE^IBCE837
  . S IBBTCH=$O(^TMP("IBCE-BATCH",$J,0))                     ; external batch#
  . I IBBTCH'="" S IBBTCH=+$G(^TMP("IBCE-BATCH",$J,IBBTCH))  ; internal batch#
  . K ^TMP("IBONE",$J),^TMP("IBSELX",$J),^TMP("IBCE-BATCH",$J)
- . ;
  . I 'IBBTCH D
  .. S DIR("A",1)="BILL NOT RESUBMITTED - CHECK ALERTS/MAIL FOR DETAILS"
  . E  D
  .. N DIE,DR,DA
  .. D UPDEDI^IBCEM(IB364,"R")   ; update EDI files for old transmission
+ .. D UPDEDI^IBCEM(IB364,"R")
  .. S DIE="^IBA(364,",DR=".06////"_+IBBTCH,DA=IB364 D ^DIE
  .. S DIR("A",1)="BILL RESUBMITTED IN BATCH #"_$P($G(^IBA(364.1,+IBBTCH,0)),U,1)
  . S DIR(0)="EA",DIR("A")="PRESS ENTER TO CONTINUE " W ! D ^DIR K DIR
  . Q
+ ;
  ; Later retransmission of claim
  D UPDEDI^IBCEM(IB364,"R")      ; update EDI files for old transmission record
  S Y=$$ADDTBILL^IBCB1(IBIFN)    ; Add a new transmission record
  S DIR("A",1)="BILL'S TRANSMISSION STATUS RESET TO 'READY TO EXTRACT'"
  S DIR(0)="EA",DIR("A")="PRESS ENTER TO CONTINUE " W ! D ^DIR K DIR
+ .. S DIR("A",1)="BILL RESUBMITTED IN BATCH #"_$P($G(^IBA(364.1,IBBTCH,0)),U)
+ . S DIR(0)="EA",DIR("A")="PRESS ENTER TO CONTINUE " D ^DIR K DIR
+ I Y="L" D
+ . N Y
+ . D UPDEDI^IBCEM(IB364,"R")
+ . ;Add a new transmission record
+ . S Y=$$ADDTBILL^IBCB1($P($G(^IBA(364,+IB364,0)),U),1)
+ . S DIR("A",1)="BILL'S TRANSMISSION STATUS RESET TO 'READY TO EXTRACT'"
+ . S DIR(0)="EA",DIR("A")="PRESS ENTER TO CONTINUE " D ^DIR K DIR
+ ;
 RESUBQ Q

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE277.m

-              r628
+              r636
 IBCE277 ;ALB/TMP - 277 EDI CLAIM STATUS MESSAGE PROCESSING ;15-JUL-98
+ ;;2.0;INTEGRATED BILLING;**137,155,368**;21-MAR-94;Build 21
+ ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**137,155**;21-MAR-94
+ Q
  ; MESSAGE HEADER DATA STRING =
 …
 HDR(ENTITY,ENTVAL,IBTYPE,IBD) ;Process header data
  ; INPUT:
+ ;   ENTITY = "BATCH" or "CLAIM" for batch/claim level messages respectively
+ ;   ENTVAL = claim #
+ ;   ENTITY = "BATCH" if batch level message
+ ;            "CLAIM" if claim level message
+ ;   ENTVAL = batch # or claim #
  ;   IBTYPE = the type of status msg this piece of the message represents
  ;             (837REC1, 837REJ1)
 …
  ; OUTPUT:
  ;   IBD array returned with processed data
+ ;      "LINE" = The last line # populated in the message
  ;      "DATE" = Date/Time of status (Fileman format)
  ;      "MRA" =  1 if MRA, 0 if not         "X12" = 1 if X12, 0 if not
 …
+ ;
  ;   ^TMP("IBMSG",$J,"BATCH",batch #,0)=MESSAGE HEADER DATA STRING
  ;                                      if batch level message
+ ;                                      if called from batch level
  ;                                  ,"D",0,1)=header record raw data
  ;                                  ,line #)=batch status message lines
+ ;
  ;   ^TMP("IBMSG",$J,"CLAIM",claim #,0)=MESSAGE HEADER DATA STRING
  ;                                      if claim level message
+ ;                                      if called from claim level
  ;                                  ,"D",0,1)=header record raw data
  ;                                  ,line #)=claim status message lines
+ ;
+ N DATA,IBD0,L,PC,X,Y
+ S IBD0=$G(^TMP("IBMSGH",$J,0)) Q:IBD0=""
+ S Y=0,L=1
+ ; Convert claim date/time
+ S X=$$DATE($P(IBD0,U,3))_"@"_$E($P(IBD0,U,4)_"0000",1,4) I X S %DT="XTS" D ^%DT
+ ; populate IBD array
+ S IBD("DATE")=$S(Y>0:Y,1:""),IBD("MRA")=$P(IBD0,U,5),IBD("X12")=($P(IBD0,U,2)="X")
+ S IBD("SOURCE")=$P(IBD0,U,12,13),IBD("BATCH")=$P(IBD0,U,14)
+ I +$TR($P(IBD0,U,6,9),U) F PC=6:1:9 D
+ .I $P(IBD0,U,PC)'="" S DATA=$P("# Claims Submitted^# Claims Rejected^Total Charges Submitted^Total Charges Rejected",U,PC-5)_": "_$S(PC<8:+$P(IBD0,U,PC),1:$FNUMBER($P(IBD0,U,PC)/100,"",2))_"  "
+ .I $L($G(^TMP("IBMSG-H",$J,ENTITY,ENTVAL,L)))+$L(DATA)>70 S L=L+1 ; if data doesn't fit into current line, go to the next line
+ .S ^TMP("IBMSG-H",$J,ENTITY,ENTVAL,L)=$G(^TMP("IBMSG-H",$J,ENTITY,ENTVAL,L))_DATA ; file this piece of data
+ .Q
+ ; file batch ref. number
+ S:IBD("BATCH")'="" L=L+1,^TMP("IBMSG-H",$J,ENTITY,ENTVAL,L)="Batch Reference Number: "_IBD("BATCH")
+ I $TR($P(IBD0,U,10,13),U)'="" D
+ .S L=L+1
+ .; generate and file Payer Name / Payer Id line
+ .S DATA="Payer Name: "_$S($P(IBD0,U,10)'="":$P(IBD0,U,10),1:"N/A")_"  Payer ID: "_$S($P(IBD0,U,11)'="":$P(IBD0,U,11),1:"N/A")
+ .S ^TMP("IBMSG-H",$J,ENTITY,ENTVAL,L)=DATA
+ .I $P(IBD0,U,12)'=""!($P(IBD0,U,13)'="") D
+ ..; generate and file Message Source line
+ ..S DATA="Source: "_$S($P(IBD0,U,12)="Y":"Sent by payer",$P(IBD0,U,13)'="":"Sent by non-payer ("_$P(IBD0,U,13)_")",1:"UNKNOWN")
+ ..S L=L+1,^TMP("IBMSG-H",$J,ENTITY,ENTVAL,L)=DATA
+ ..Q
+ .Q
+ S ^TMP("IBMSG",$J,ENTITY,ENTVAL,0)=IBTYPE_U_$G(IBD("MSG#"))_U_$G(IBD("SUBJ"))_U_$$GETBILL(ENTVAL)_U_U_IBD("DATE")_U_IBD("SOURCE")
+ ; file raw data
+ N CT,CT1,IBBILL,IBD0,L,LINE,PC,Z,X,Y
+ S IBD0=$G(^TMP("IBMSGH",$J,0)),IBD("LINE")=0
+ Q:IBD0=""
+ S Y=0,X=$$DATE($P(IBD0,U,3))_"@"_$E($P(IBD0,U,4)_"0000",1,4)
+ I X S %DT="XTS" D ^%DT
+ S IBD("DATE")=$S(Y>0:Y,1:"")
+ S IBD("MRA")=$P(IBD0,U,5),IBD("X12")=($P(IBD0,U,2)="X")
+ S IBD("SOURCE")=$P(IBD0,U,12,13)
+ S CT=0
+ ;
+ I ENTITY="BATCH",ENTVAL'="" D  ;Only pertinent for batch level extract
+ . S IBD("BATCH")=$O(^IBA(364.1,"B",ENTVAL,0))
+ . F PC=6:1:9 D
+ .. I $P(IBD0,U,PC)'="" S DATA=$P("# Claims Submitted^# Claims Rejected^Total Charges Submitted^Total Charges Rejected",U,PC-5)_": "_$S(PC<8:+$P(IBD0,U,PC),1:$FNUMBER($P(IBD0,U,PC)/100,"",2))_"  "
+ .. I CT,$L($G(LINE(CT)))+$L(DATA)>80 S CT=CT+1
+ .. S:'CT CT=1 S LINE(CT)=$G(LINE(CT))_DATA
+ ;
+ I ENTVAL'="",$TR($P(IBD0,U,10,13),U)'="" S CT1=CT,CT=CT+1 F PC=10,11,12 D  ;Both batch, claim levels extract
+ . Q:$P(IBD0,U,PC)=""
+ . I PC<12 S LINE(CT)=$G(LINE(CT))_$P("Payer Name^Payer ID",U,PC-9)_": "_$P(IBD0,U,PC)_"  ",CT1=CT Q
+ . I $P(IBD0,U,12)'=""!($P(IBD0,U,13)'="") S:$P(IBD0,U,10)'=""!($P(IBD0,U,11)'="") CT=CT+1 S LINE(CT)="Source: "_$S($P(IBD0,U,12)="Y":"Sent by payer",$P(IBD0,U,13)'="":"Sent by non-payer ("_$P(IBD0,U,13)_")",1:"UNKNOWN")_"  "
+ ;
+ I CT D
+ . S (L,Z)=0
+ . F  S Z=$O(LINE(Z)) Q:'Z  S L=L+1,^TMP("IBMSG-H",$J,ENTITY,ENTVAL,L)=LINE(Z)
+ . ;S IBD("LINE")=$G(IBD("LINE"))+CT
+ ;
+ I ENTITY="CLAIM" D
+ . N Z0
+ . S Z0=+$O(^DGCR(399,"B",ENTVAL,0))
+ . I $G(IBD("BATCH")) S IBBILL=$O(^IBA(364,"ABABI",+$G(IBD("BATCH")),Z0,""),-1) Q
+ . S IBBILL=$$LAST364^IBCEF4(Z0)
+ S ^TMP("IBMSG",$J,ENTITY,ENTVAL,0)=IBTYPE_U_$G(IBD("MSG#"))_U_$G(IBD("SUBJ"))_U_$S(ENTITY="CLAIM":IBBILL,1:"")_U_$S(ENTITY="BATCH":ENTVAL,1:"")_U_IBD("DATE")_U_IBD("SOURCE")
+ ;
  S ^TMP("IBMSG",$J,ENTITY,ENTVAL,"D",0,1)="##RAW DATA: "_IBD0
+ Q
+ ;
+(IBD) ; Process Message Header record
+ ; INPUT:
+ ;   IBD must be passed by reference = entire message line
+ ; OUTPUT:
+ ;   IBD array returned with processed data
+ ;      "CLAIM" = claim #
+ ;      "LINE" = last line # populated in the message
+ ;
+ ;   ^TMP("IBMSG",$J,"CLAIM",claim #,line#)= message data lines
+ ;                                  ,"D",9,msg seq #)= raw data
+ N ENTITY,ERR,FLD,IBCLM,IBIFN,L
+ D STRTREC Q:IBCLM=""  ; if no claim/batch number, bail out
+ ; make sure that we have data to file
+ S ERR=$P(IBD,U,4) Q:ERR=""
+ ; file error along with corresponding field number (if available)
+ S L=L+1,FLD=$P(IBD,U,5),^TMP("IBMSG",$J,ENTITY,IBCLM,L)="Error"_$S(FLD'="":" in field "_FLD,1:"")_":"
+ S L=L+1,^TMP("IBMSG",$J,ENTITY,IBCLM,L)=ERR
+ D ENDREC(9)
+ Q
+ ;
+(IBD) ; Process message data
+ ; INPUT:
+ ;   IBD must be passed by reference = entire message line
+ ; OUTPUT:
+ ;   IBD array returned with processed data
+ ;      "CLAIM" = claim #
+ ;      "LINE" = last line # populated in the message
+ ;
+ ;   ^TMP("IBMSG",$J,"CLAIM",claim #,line#)= message data lines
+ ;                                  ,"D",10,msg seq #)= raw data
+(IBD) ; Process batch status data
+ ; INPUT:
+ ;   IBD must be passed by reference = entire message line
+ ; OUTPUT:
+ ;   IBD array returned with processed data
+ ;      "LINE" = The last line # populated in the message
+ ;
+ ;   ^TMP("IBMSG",$J,"BATCH",batch #,line#)=batch status message lines
+ ;                                  ,"D",5,msg seq #)=
+ ;                                       batch status message raw data
+ ;
+ N CT,DATA,IBBTCH,IBTYPE,L,LINE,Z
+ K ^TMP("IBCONF",$J)
+ S IBBTCH=+$P(IBD,U,2)
+ S IBTYPE=$S($P(IBD,U,3)="R":"837REJ1",1:"837REC1")
+ I '$D(^TMP("IBMSG",$J,"BATCH",IBBTCH)) D HDR("BATCH",IBBTCH,IBTYPE,.IBD) ;Process header data if not already done for batch
+ S CT=0,LINE(1)=""
+ S DATA=$P(IBD,U,4)
+ I DATA'="",$TR($P(IBD,U,5,7),U)'="" D
+ . Q:$G(^TMP("IBMSG",$J,"BATCH",IBBTCH))=DATA
+ . S:'CT CT=CT+1 S LINE(CT)=$G(LINE(CT))_$S(DATA="W":"Warning",DATA="E":"Error",1:"Informational")_"  "
+ S ^TMP("IBMSG",$J,"BATCH",IBBTCH)=DATA
+ I $P(IBD,U,5)'="" S:'CT CT=CT+1 S LINE(CT)=$G(LINE(CT))_"Code: "_$P(IBD,U,5)
+ I $P(IBD,U,6)'="" S:'CT CT=CT+1 S LINE(CT)=$G(LINE(CT))_"  "_$P(IBD,U,6),CT=CT+1
+ I $P(IBD,U,7)'="" S:'CT CT=CT+1 S LINE(CT)=$G(LINE(CT))_"  "_$P(IBD,U,7)
+ I CT D
+ . S L=$G(IBD("LINE")),Z=0
+ . F  S Z=$O(LINE(Z)) Q:'Z  S L=L+1,^TMP("IBMSG",$J,"BATCH",IBBTCH,L)=LINE(Z)
+ . S ^TMP("IBMSG",$J,"BATCH",IBBTCH,"D",5,$O(^TMP("IBMSG",$J,"BATCH",IBBTCH,"D",5,""),-1)+1)="##RAW DATA: "_IBD
+ . S IBD("LINE")=$G(IBD("LINE"))+CT
+ Q
+ ;
+(IBD) ; Process claim status data
+ ; INPUT:
+ ;   IBD must be passed by reference = entire message line
+ ; OUTPUT:
+ ;   IBD array returned with processed data
+ ;      "CLAIM" = The claim #
+ ;      "LINE" = The last line # populated in the message
+ ;
+ ;   ^TMP("IBMSG",$J,"CLAIM",claim #,line#)=claim status message lines
+ ;                                  ,"D",10,msg seq #)=
+ ;                                       claim status raw data
  ;   ^TMP("IBCONF",$J,claim #")="" for invalid claims within the batch
+ ;
+ N CODE,DATA,ENTITY,IBCLM,IBIFN,IBTYPE,L,Z
+ D STRTREC Q:IBCLM=""  ; if no claim number, bail out
+ S:$P(IBD,U,3)="R" ^TMP("IBCONF",$J,IBIFN)=""
+ N CT,DATA,IBCLM,IBTYPE,L,LINE,Z
+ S IBCLM=$$GETCLM($P(IBD,U,2))
+ Q:IBCLM=""
+ S:$P(IBD,U,3)="R" ^TMP("IBCONF",$J,+$O(^DGCR(399,"B",IBCLM,0)))=""
  S IBTYPE=$S($P(IBD,U,3)="R":"837REJ1",1:"837REC1")
+ ;Process header data if not already done
+ I '$D(^TMP("IBMSG",$J,ENTITY,IBCLM,0)) D HDR(ENTITY,IBCLM,IBTYPE,.IBD)
+ I IBTYPE="837REJ1",$P($G(^TMP("IBMSG",$J,ENTITY,IBCLM,0)),U,1)'="837REJ1" D HDR(ENTITY,IBCLM,IBTYPE,.IBD)
+ S CODE=$P(IBD,U,4) I CODE'="",$TR($P(IBD,U,5,6),U)'="" D
+ .S Z=CODE_$P(IBD,U,5) I Z'=$G(IBD("SCODE")) D
+ ..; determine type of status code and file it
+ ..S L=L+1,DATA=$S(CODE="W":"Warning",CODE="E":"Error",1:"Informational")_" "
+ ..I $P(IBD,U,5)'="" S ^TMP("IBMSG",$J,ENTITY,IBCLM,L)=DATA_"Code: "_$P(IBD,U,5)
+ ..I $P(IBD,U,6)'="" S:$P(IBD,U,5)'="" L=L+1 S ^TMP("IBMSG",$J,ENTITY,IBCLM,L)=DATA_"Message:",L=L+1
+ ..S IBD("SCODE")=Z
+ ..Q
+ .; file status message
+ .I $P(IBD,U,6)'="" S ^TMP("IBMSG",$J,ENTITY,IBCLM,L)=$P(IBD,U,6),L=L+1,^TMP("IBMSG",$J,ENTITY,IBCLM,L)=" "
+ .Q
+ D ENDREC(10)
+ Q
+ ;
+(IBD) ; Process claim data
+ ; Claim must have been referenced by a previous '10' level
+ ; INPUT:
+ ;   IBD must be passed by reference = entire message line
+ ;
+ ; OUTPUT:
+ ;      IBD("LINE") = The last line # populated in the message
+ ;
+ ;     ^TMP("IBMSG",$J,"CLAIM",claim #,line#)=claim data lines
+ ;                                    ,"D",13,msg seq #)=raw data
+ ;
+ N CTYPE,ENTITY,IBCLM,IBIFN,L,Z1,Z2
+ D STRTREC
+ ; quit if no claim number or no previous 'line 10' record
+ Q:$S(IBCLM="":1,1:'$D(^TMP("IBMSG",$J,"CLAIM",IBCLM)))
+ ; file clearinghouse trace number
+ I $P(IBD,U,3)'="" S L=L+1,^TMP("IBMSG",$J,ENTITY,IBCLM,L)="Clearinghouse Trace Number: "_$P(IBD,U,3)
+ ; file payer status date
+ I $P(IBD,U,4)'="" S L=L+1,^TMP("IBMSG",$J,ENTITY,IBCLM,L)="         Payer Status Date: "_$$DATE($P(IBD,U,4))
+ ; file payer claim number
+ I $P(IBD,U,5)'="" S L=L+1,^TMP("IBMSG",$J,ENTITY,IBCLM,L)="        Payer Claim Number: "_$P(IBD,U,5)
+ ; file split claim indicator
+ I +$P(IBD,U,6)'=0 S L=L+1,^TMP("IBMSG",$J,ENTITY,IBCLM,L)="               Split Claim: "_$S(+$P(IBD,U,6)=1:"No",1:"Yes ("_+$P(IBD,U,6)_" parts)")
+ ; file claim type if it either doesn't match value in VistA or if it's a dental claim
+ S Z1=$P(IBD,U,7),Z2=$$FT^IBCEF(IBIFN),CTYPE=$S(Z1="P"&(Z2'=2):"Professional",Z1="I"&(Z2'=3):"Institutional",Z1="D":"Dental",1:"")
+ S:CTYPE'="" L=L+1,^TMP("IBMSG",$J,ENTITY,IBCLM,L)="                Claim Type: "_CTYPE
+ D ENDREC(13)
+ I '$D(^TMP("IBMSG",$J,"CLAIM",IBCLM)) D HDR("CLAIM",IBCLM,IBTYPE,.IBD) ;Process header data if not already done for claim
+ I IBTYPE="837REJ1",$P($G(^TMP("IBMSG",$J,"CLAIM",IBCLM,0)),U,1)'="837REJ1" D HDR("CLAIM",IBCLM,IBTYPE,.IBD)
+ S CT=0,DATA=$P(IBD,U,4)
+ I DATA'="",$TR($P(IBD,U,5,7),U)'="" D
+ . Q:$G(^TMP("IBMSG",$J,"CLAIM",IBCLM))=DATA
+ . S ^TMP("IBMSG",$J,"CLAIM",IBCLM)=DATA
+ . S CT=CT+1,LINE(CT)=$G(LINE(CT))_$S(DATA="W":"Warning",DATA="E":"Error",1:"Informational")_"  "
+ I $P(IBD,U,5)'="" S CT=$S('CT:1,1:CT),LINE(CT)=$G(LINE(CT))_"Code: "_$P(IBD,U,5)
+ I $P(IBD,U,6)'="" S CT=$S('CT:1,1:CT),LINE(CT)=$G(LINE(CT))_"  "_$P(IBD,U,6)
+ I $P(IBD,U,7)'="" S CT=CT+1,LINE(CT)="  "_$P(IBD,U,7)
+ I CT D
+ . S L=$G(IBD("LINE")),Z=0
+ . F  S Z=$O(LINE(Z)) Q:'Z  S L=L+1,^TMP("IBMSG",$J,"CLAIM",IBCLM,L)=LINE(Z)
+ . S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",10,$O(^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",10,""),-1)+1)="##RAW DATA: "_IBD
+ . S IBD("LINE")=$G(IBD("LINE"))+CT
+ Q
+ ;
 …
  ;                                         subscr/patient raw data
+ ;
+ N ENTITY,DATA,IBCLM,IBIFN,IBNM,IBNUM,IBDFN,L
+ D STRTREC
+ ; quit if no claim number or no previous 'line 10' record
+ N CT,Z,L,LINE,DATA,IBCLM,IBNM,IBNUM,IBDFN
+ S IBCLM=$$GETCLM($P(IBD,U,2)),CT=0,L=$G(IBD("LINE"))
  Q:$S(IBCLM="":1,1:'$D(^TMP("IBMSG",$J,"CLAIM",IBCLM)))
  S IBDFN=+$P(^DGCR(399,IBIFN,0),U,2)
+ S IBDFN=+$G(^DGCR(+$O(^DGCR(399,"B",IBCLM,0)),0))
  S IBNM=$S($P(IBD,U,3)'="":$P(IBD,U,3)_","_$P(IBD,U,4)_$S($P(IBD,U,5)'="":" "_$P(IBD,U,5),1:""),1:$P($G(^DPT(IBDFN,0)),U))
  S IBNUM=$S($P(IBD,U,6)'="":$P(IBD,U,6),1:$P($G(^DPT(IBDFN,0)),U,9))
  S L=L+1,^TMP("IBMSG",$J,ENTITY,IBCLM,L)="Patient: "_IBNM_"   "_IBNUM
+ S CT=CT+1,LINE(CT)="Patient: "_IBNM_"   "_IBNUM
  I $P(IBD,U,11) D
+ .S DATA=$$DATE($P(IBD,U,11)),L=L+1
+ .S ^TMP("IBMSG",$J,ENTITY,IBCLM,L)="Service Dates: "_DATA_" - "_$S($P(IBD,U,12):$$DATE($P(IBD,U,12)),1:DATA)
+ .Q
+ D ENDREC(15)
+ Q
+ ;
+STRTREC ; start processing of the record
+ ;
+ ; OUTPUT:
+ ;   sets the following variables
+ ;   IBCLM = claim #
+ ;   ENTITY = "CLAIM" (all 277STAT messages are on claim level)
+ ;   L = last populated line number
+ ;
+ S IBCLM=$$GETCLM($P(IBD,U,2)),ENTITY="CLAIM",L=+$G(IBD("LINE"))
+ S IBIFN=+$O(^DGCR(399,"B",IBCLM,0))
+ Q
+ ;
+ENDREC(TYPE) ; finish processing of the record
+ ; INPUT:
+ ;   TYPE = record type (line type)
+ ;
+ ; OUTPUT:
+ ;   IBD("LINE") = is updated with last populated line number
+ ;
+ ;make sure all variables are set properly
+ Q:$G(ENTITY)=""
+ Q:$G(IBCLM)=""
+ Q:$G(TYPE)=""
+ ; file raw data
+ S ^TMP("IBMSG",$J,ENTITY,IBCLM,"D",TYPE,$O(^TMP("IBMSG",$J,ENTITY,IBCLM,"D",TYPE,""),-1)+1)="##RAW DATA: "_IBD
+ ; update line count
+ S IBD("LINE")=$G(IBD("LINE"))+L
+ Q
+ ;
+GETBILL(CLAIM) ; Extract transmission #
+ N TRANS
+ S TRANS=$$LAST364^IBCEF4(IBIFN)
+ ; if status of the last transmission is "X" or "P", keep searching backwards through file 364 until record
+ ; with different status is found
+ I TRANS F  Q:"XP"'[$P(^IBA(364,TRANS,0),U,3)  S TRANS=$O(^IBA(364,"B",IBIFN,TRANS),-1) Q:TRANS=""  ;
+ Q +TRANS
+ . S DATA=$$DATE($P(IBD,U,11)),CT=CT+1
+ . S LINE(CT)="Service Dates: "_DATA_" - "_$S($P(IBD,U,12):$$DATE($P(IBD,U,12)),1:DATA)_"  "
+ . ; Add additional lines of display data here for record 15
+ S Z=0 F  S Z=$O(LINE(Z)) Q:'Z  S L=L+1,^TMP("IBMSG",$J,"CLAIM",IBCLM,L)=LINE(Z)
+ S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",15,$O(^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",15,""),-1)+1)="##RAW DATA: "_IBD
+ S IBD("LINE")=$G(IBD("LINE"))+CT
+ Q
+ ;
+(IBD) ; Process service line status data
+ ; Claim must have been referenced by a previous '10' level
+ ; INPUT:
+ ;   IBD must be passed by reference = entire message line
+ ; OUTPUT:
+ ;   IBD array returned with processed data
+ ;      "LINE" = The last line # populated in the message
+ ;      "TYPE" = The msg type of status record (Confirmation/rejection)
+ ;             Note: returned if not already set at batch or claim level
+ ;
+ ;   ^TMP("IBMSG",$J,"CLAIM",claim #)=""
+ ;                                  ,line#)=service line status msg lines
+ ;                                  ,"D",20,msg seq #)=
+ ;                                       service line status raw data
+ ;
+ N CT,DATA,L,LINE,Z,IBCLM,IBLNUM
+ S IBCLM=$$GETCLM($P(IBD,U,2)),IBLNUM=$P(IBD,U,8)
+ Q:'$D(^TMP("IBMSG",$J,"CLAIM",IBCLM))
+ S CT=0
+ I IBLNUM'="" S CT=CT+1,LINE(CT)="Claim Line: "_IBLNUM,^TMP("IBMSG",$J,"LINE",IBCLM,IBLNUM)=""
+ S DATA=$P(IBD,U,4)
+ I DATA'="",$TR($P(IBD,U,5,7),U)'="" S:'CT CT=CT+1 S LINE(CT)=$S(DATA="W":"Warning",DATA="E":"Error",1:"Informational")_"  "_$G(LINE(CT))
+ S:$G(IBD("TYPE"))="" IBD("TYPE")=$S(DATA="E":"837REJ1",1:"837REC1")
+ I $P(IBD,U,5)'="" S:'CT CT=CT+1 S LINE(CT)=LINE(CT)_$P(IBD,U,5)
+ I $P(IBD,U,6)'="" S CT=CT+1,LINE(CT)="  "_$P(IBD,U,6)
+ I $P(IBD,U,7)'="" S CT=CT+1,LINE(CT)="  "_$P(IBD,U,7)
+ I CT D
+ . S L=$G(IBD("LINE")),Z=0
+ . F  S Z=$O(LINE(Z)) Q:'Z  S L=L+1,^TMP("IBMSG",$J,"CLAIM",IBCLM,L)=LINE(Z)
+ . S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",20,$O(^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",20,""),-1)+1)="##RAW DATA: "_IBD
+ . S IBD("LINE")=$G(IBD("LINE"))+CT
+ Q
+ ;
+(IBD) ; Process service line ID data
+ ; Moved for size too big
+ D 21^IBCE277A(IBD)
+ Q
+ ;
 DATE(DT) ; Convert YYMMDD Date into MM/DD/YY or YYYYMMDD into MM/DD/YYYY
 …
 GETCLM(X) ; Extract the claim # without site id from the data in X
  N IBCLM
+ S IBCLM=$P(X,"-",2) I IBCLM="",X'="" S IBCLM=$E(X,$S($L(X)>7:4,1:1),$L(X))
+ S IBCLM=$P(X,"-",2)
+ I IBCLM="",X'="" S IBCLM=$E(X,$S($L(X)>7:4,1:1),$L(X))
+ ;S IBCLM=$E(X,$L(IBCLM)-6,$L(IBCLM)) ; Only take last 7 char
  Q IBCLM
+ ;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE835.m

-              r628
+              r636
 IBCE835 ;ALB/TMP - 835 EDI EXPLANATION OF BENEFITS MSG PROCESSING ;19-JAN-99
+ ;;2.0;INTEGRATED BILLING;**137,135,155,377**;21-MAR-94;Build 23
+ ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+ ;;2.0;INTEGRATED BILLING;**137,135,155**;21-MAR-94
+ Q
+ ;
 …
  I '$D(^TMP("IBMSG",$J,"CLAIM",IBBILL)) D HDR(IBBILL,.IBD) ;Process header data if not already done for claim
+ ;
+ I $P(IBD,U,7)="Y"!($P(IBD,U,8)="Y") D  ;New patient name or id reported
+ . ;
+ . ; Alert to EDI mail group that name or ID has changed
+ . N XQA,XQAMSG
+ . S XQA("G.IB EDI")=""
+ . S XQAMSG="EOB for bill # "_IBBILL_" indicates a new name or id exists for patient"
+ . D SETUP^XQALERT
+ . ;
+ . S IBD("LINE")=$G(IBD("LINE"))+1
+ . I $P(IBD,U,7)="Y" S ^TMP("IBMSG",$J,"CLAIM",IBBILL,IBD("LINE"))="New patient name: "_$P(IBD,U,3)_","_$P(IBD,U,4)_" "_$P(IBD,U,5)_"  "
+ . I $P(IBD,U,8)="Y" S ^TMP("IBMSG",$J,"CLAIM",IBBILL,IBD("LINE"))=$G(^TMP("IBMSG",$J,"CLAIM",IBBILL,IBD("LINE")))_"New patient id: "_$P(IBD,U,6)
+ ;
  I $P(IBD,U,9) D  ;Statement dates
  . S IBD("LINE")=$G(IBD("LINE"))+1
 …
  S ^TMP("IBMSG",$J,"CLAIM",IBBILL,"D",5,1)="##RAW DATA: "_IBD
  S ^TMP("IBMSG",$J,"CLAIM",IBBILL,"D1",1,5)="##RAW DATA: "_IBD
+ Q
+ ;
-(IBD) ; Process 06 record type for corrected name and/or ID# - IB*2*377 - 1/14/08
- NEW IBCLM,Z
- S IBCLM=$$GETCLM^IBCE277($P(IBD,U,2))
- Q:IBCLM=""
- I '$D(^TMP("IBMSG",$J,"CLAIM",IBCLM)) D HDR(IBCLM,.IBD)   ;Process header data if not already done for claim
+ ;
- S Z=$G(IBD("LINE"))
- I $P(IBD,U,3)'="" S Z=Z+1,^TMP("IBMSG",$J,"CLAIM",IBCLM,Z)="Corrected Patient Last Name: "_$P(IBD,U,3)
- I $P(IBD,U,4)'="" S Z=Z+1,^TMP("IBMSG",$J,"CLAIM",IBCLM,Z)="Corrected Patient First Name: "_$P(IBD,U,4)
- I $P(IBD,U,5)'="" S Z=Z+1,^TMP("IBMSG",$J,"CLAIM",IBCLM,Z)="Corrected Patient Middle Name: "_$P(IBD,U,5)
- I $P(IBD,U,6)'="" S Z=Z+1,^TMP("IBMSG",$J,"CLAIM",IBCLM,Z)="Corrected Patient ID#: "_$P(IBD,U,6)
- S IBD("LINE")=Z
+ ;
- S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",6,1)="##RAW DATA: "_IBD
- S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D1",1,6)="##RAW DATA: "_IBD
+ Q
+ ;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE837A.m

-              r628
+              r636
 IBCE837A ;ALB/TMP - OUTPUT FOR 837 TRANSMISSION - CONTINUED ;8/6/03 10:50am
+ ;;2.0;INTEGRATED BILLING;**137,191,211,232,296,377**;21-MAR-94;Build 23
+ ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**137,191,211,232,296**;21-MAR-94
+ ;
 UPD(MSGNUM,BATCH,CNT,BILLS,DESC,IBBTYP,IBINS) ; Upd current batch + bills w/new status
 …
  .S DA=IBIEN,DIE="^IBA(364,",DR=".02////"_IBBATCH_";.03///P;.04///NOW" D ^DIE
  .S IBIFN=+$G(^IBA(364,IBIEN,0))
- . ;
- . ; If this claim has just been retransmitted, set the .06 field for the previous transmission entry
- . N PRVTXI,PRVTXD
- . S PRVTXI=$O(^IBA(364,"B",IBIFN,IBIEN),-1)      ; previous transmission for this claim
- . I PRVTXI D
- .. S PRVTXD=$G(^IBA(364,PRVTXI,0))
- .. I '$F(".R.E.","."_$P(PRVTXD,U,3)_".") Q                 ; prev trans must have status of "R" or "E"
- .. I $P(PRVTXD,U,7,8)'=$P($G(^IBA(364,IBIEN,0)),U,7,8) Q   ; test bill and COB must be the same
- .. S DA=PRVTXI,DIE=364,DR=".06///"_IBBATCH D ^DIE          ; update the resubmit batch number
- .. Q
- . ;
  .Q:$D(^TMP("IBRESUBMIT",$J))!($P($G(^DGCR(399,IBIFN,0)),U,13)=4)!(+$$TXMT^IBCEF4(IBIEN)=2)
  .S IBMRA=$$NEEDMRA^IBEFUNC(IBIFN)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEBUL.m

-              r628
+              r636
 IBCEBUL ;ALB/TMP - 837 EDI SPECIAL BULLETINS PROCESSING ;19-SEP-96
+ ;;2.0;INTEGRATED BILLING;**137,250,377**;21-MAR-94;Build 23
+ ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**137,250**;21-MAR-94
+ ;
 NOTSENT ; Check for batches in pending status (no confirmation from Austin)
  ;  from yesterday or before
  N XMTO,XMSUBJ,XMBODY,XMDUZ,IBT,IB,IBE,IBCT,IBI,IB0,IB1,Z,IBTYP
+ N XMTO,XMSUBJ,XMBODY,XMDUZ,IBT,IB,IBE,IBCT,IBI,IB0,IB1,Z,IBDTM
  K ^TMP($J,"IBNOTSENT")
+ D NOW^%DTC S IBDTM=%
  S (IBCT,IBI)=0
+ F  S IBI=$O(^IBA(364.1,"ASTAT","P",IBI)) Q:'IBI  D
+ . I $$BCHCHK(IBI) Q    ; Batch check function
+ . S IBCT=IBCT+1
+ . S IBTYP=$P($G(^IBA(364.1,IBI,0)),U,7)
+ . I IBCT'>10,IBTYP'="" S ^TMP($J,"IBNOTSENT",IBTYP,IBI)=""
+ . Q
+ ;
+ F  S IBI=$O(^IBA(364.1,"ASTAT","P",IBI)) Q:'IBI  S IBTYP=$P($G(^IBA(364.1,IBI,0)),U,7),IBDAYS=(IBDTM-$P($G(^(1)),U,6)) I IBDAYS>1,IBDAYS'=IBDTM,$O(^IBA(364,"C",IBI,0)) D
+ .S IBCT=IBCT+1,IBCT(+IBTYP)=$G(IBCT(+IBTYP))+1
+ .I IBCT'>10 S ^TMP($J,"IBNOTSENT",IBTYP,IBI)=""
  I IBCT D
  .S IBT(1)="There are "_IBCT_" EDI batch(es) still pending Austin receipt "
 …
  .S IBT(3)="as being received by Austin."
  .S IBT(4)=" "
  .I IBCT>10 S IBT(5)="Since there were more than 10 batches found, please run the ",IBT(6)="  EDI BATCHES PENDING RECEIPT report to get a list of these batches."
+ .I IBCT>10 S IBT(5)="Since there were more than 10 batches found, please run the ",IBT(6)="  EDI BATCHES WAITING FOR AUSTIN RECEIPT OVER 1-DAY report to get a list of these batches."
  .I IBCT'>10 D
  ..S IBT(5)="      BATCH #      PENDING SINCE             MAIL MESSAGE #",IBT(6)="",$P(IBT(6),"-",76)="",IBT(6)="  "_IBT(6),IBE=6
 …
  ....S IBT(IBE)="      "_$E($P(IB0,U)_$J("",10),1,10)_"   "_$E($$FMTE^XLFDT($P(IB1,U,6),1)_$J("",20),1,20)_"      "_$P(IB0,U,4),IBE=IBE+1,IBT(IBE)=$J("",8)_$E($P(IB0,U,8),1,72)
  .S XMSUBJ="EDI BATCHES WAITING AUSTIN RECEIPT FOR OVER 1 DAY",XMBODY="IBT",XMDUZ="",XMTO("I:G.IB EDI")=""
  .D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO)
+ .D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ)
  K ^TMP($J,"IBNOTSENT")
+ Q
+ ;
-UPDBCH(BCHIEN) ; update the status of this batch to show A0:received in Austin
- NEW DIE,DA,DR
- S DIE=364.1,DA=+BCHIEN,DR=".02///A0"
- I $D(^IBA(DIE,DA,0)) D ^DIE
-UPDBCHX ;
+ Q
+ ;
-BCHCHK(BCHIEN) ; This function will check the EDI claims associated with this
- ; batch and determine if this batch has been received in Austin or not.
+ ;
- ; ** This function is also called by routine IBCERP3 **
+ ;
- ; Function value = 1 if we can determine that the batch was received in Austin, or
- ;                = 1 if there are no claims in this batch, or
- ;                = 1 if the batch is less than 24 hours old - too new to worry about
- ;                = 1 means don't display on report or MailMan message
+ ;
- ; Function value = 0 if the batch has not yet been received in Austin
- ;                = 0 means we need to display batch on report and in MailMan message
+ ;
- NEW IBEDI,IBOK,IBZ,IBIFN,IB0,AR,IBSECS
- S IBEDI=0,IBOK=1,BCHIEN=+$G(BCHIEN)
+ ;
- ; if the batch transmission is still less than 24 hours old, skip this batch and get out
- S IBSECS=$$FMDIFF^XLFDT($$NOW^XLFDT,$P($G(^IBA(364.1,BCHIEN,1)),U,6),2)
- I IBSECS<86400 G BCHCHKX    ; # seconds in a day
+ ;
- ; if no edi claims in this batch, update batch status and get out
- I '$O(^IBA(364,"C",BCHIEN,0)) D UPDBCH(BCHIEN) G BCHCHKX
+ ;
- F  S IBEDI=$O(^IBA(364,"C",BCHIEN,IBEDI)) Q:'IBEDI  D  Q:'IBOK
- . S IBZ=$G(^IBA(364,IBEDI,0))
- . S IBIFN=+IBZ,IB0=$G(^DGCR(399,IBIFN,0))
- . I $P(IB0,U,13)=7 Q                    ; cancelled in IB
- . I $P(IBZ,U,3)'="P" Q                  ; edi claim status is not pending
- . S AR=$P($$BILL^RCJIBFN2(IBIFN),U,2)   ; AR status DBIA 1452
- . I $F(".22.26.39.","."_AR_".") Q       ; collected/closed or cancelled
- . ;
- . ; if we get to this point, then we have found an EDI claim in this batch
- . ; that is not cancelled in IB, the EDI claim status is "P", and the
- . ; AR status is not collected/closed nor cancelled in AR.  So therefore
- . ; this claim didn't get to Austin, so the batch didn't get to Austin.
- . S IBOK=0
- . Q
+ ;
- ; If we find the batch has been received in Austin, then change the batch status.
- I IBOK D UPDBCH(BCHIEN)
+ ;
-BCHCHKX ;
- Q IBOK
+ ;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECOB1.m

-              r628
+              r636
 IBCECOB1 ;ALB/CXW - IB COB MANAGEMENT SCREEN/REPORT ;14-JUN-99
+ ;;2.0;INTEGRATED BILLING;**137,155,288,348,377**;21-MAR-94;Build 23
+ ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**137,155,288,348**;21-MAR-94;Build 5
+ ;
 BLD ; Build list entrypoint
 …
  .. S X=""
  .. S X=$$SETFLD^VALM1(IBCNT,X,"NUMBER")
  .. S X=$$SETFLD^VALM1($$BN1^PRCAFN(IBIFN)_$S($P($G(^DGCR(399,IBIFN,"TX")),U,10)=1:"*",1:""),X,"BILL")
+ .. S X=$$SETFLD^VALM1($$BN1^PRCAFN(IBIFN),X,"BILL")
  .. S X=$$SETFLD^VALM1($$DAT1^IBOUTL($P(IB,U)),X,"SERVICE")
  .. S X=$$SETFLD^VALM1(IBPAT,X,"PATNM")

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECSA1.m

-              r628
+              r636
 IBCECSA1 ;ALB/CXW - IB STATUS AWAITING RESOLUTION SCREEN ;28-JUL-99
+ ;;2.0;INTEGRATED BILLING;**137,283,288,320,368**;21-MAR-94;Build 21
+ ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**137,283,288,320**;21-MAR-94
  ; DBIA for $$BN1^PRCAFN()
+ ;
 …
  . ;
  . S IBSTSMSG=$$TXT(IBDA)       ; status message text
  . S IBERR=$E(IBSTSMSG,1,60)
+ . S IBERR=$E(IBSTSMSG,1,30)
  . I IBERR="" S IBERR="-"
  . ;
 …
  F  S LN=$O(^IBM(361,+$G(IBDA),1,LN)) Q:'LN  D  Q:STOP
  . S TX=$G(^IBM(361,IBDA,1,LN,0))
+ . I $E(TX,1,5)="Error" S TX=$E(TX,6,999)
  . S TX=$$TRIM^XLFSTR(TX)
- . ; Don't include parts added by ^IBCE277
- . Q:TX="Informational Message:"
- . Q:TX="Warning Message:"
- . Q:TX="Error Message:"
- . I $E(TX,1,27)="Clearinghouse Trace Number:" S STOP=1 Q
- . I $E(TX,1,18)="Payer Status Date:" S STOP=1 Q
- . I $E(TX,1,19)="Payer Claim Number:" S STOP=1 Q
- . I $E(TX,1,12)="Split Claim:" S STOP=1 Q
- . I $E(TX,1,11)="Claim Type:" S STOP=1 Q
  . I $E(TX,1,8)="Patient:" S STOP=1 Q
  . I $E(TX,1,14)="Service Dates:" S STOP=1 Q
  . I $E(TX,1,11)="Payer Name:" S STOP=1 Q
  . I $E(TX,1,7)="Source:" S STOP=1 Q
+ . I $E(TX,1,11)="Claim Line:" S STOP=1 Q
+ . I $E(TX,1,13)="Service Type:" S STOP=1 Q
  . I TX["HL=" S HLN=+$P(TX,"HL=",2),DELIM="HL="_HLN,TX=$P(TX,DELIM,1)_"HL= "_$P(TX,DELIM,2,9)
  . I TX["ENVOY REF: " S REFN=$E($P(TX,"ENVOY REF: ",2),1,14),DELIM="ENVOY REF: "_REFN,TX=$P(TX,DELIM,1)_"ENVOY REF: "_$P(TX,DELIM,2,9)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECSA3.m

-              r628
+              r636
 IBCECSA3 ;ALB/CXW - CLAIMS STATUS AWAITING RESOLUTION REPORT ;23-JUL-99
+ ;;2.0;INTEGRATED BILLING;**137,320,371,377**;21-MAR-94;Build 23
+ ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**137,320**;21-MAR-94
+ Q
 EN ; Report of claims status awaiting resolution
- NEW %ZIS,ZTSAVE,ZTRTN,ZTDESC,DIR,X,Y,DIRUT,DTOUT,DUOUT,DIROUT,IBRVW
+ ;
  D FULL^VALM1
- W !
- S DIR(0)="YO"           ; IB*2*377 new question
- S DIR("A")="Would you like to include Review Comments with this report"
- S DIR("B")="No"
- D ^DIR K DIR
- I $D(DIRUT) Q
- S IBRVW=Y
+ ;
  W !!,"You will need a 132 column printer for this report!",!
+ ;
+ N %ZIS,ZTSAVE,ZTRTN,ZTDESC
  S %ZIS="QM" D ^%ZIS Q:POP
  I $D(IO("Q")) K IO("Q") D  Q
 …
  . S ZTSAVE("IBSORTOR")=""
  . S ZTSAVE("^TMP(""IBCECSB"",$J,")=""
- . S ZTSAVE("IBRVW")=""
  . S ZTDESC="IB -Claims Status Awaiting Resolution Report" D ^%ZTLOAD K ZTSK D HOME^%ZIS
  U IO
 …
  I '$D(^TMP("IBCECSB",$J)) D  G LISTQ
  . D HDR1 W !,"No entries found for this report"
  S IBX="" F  S IBX=$O(^TMP("IBCECSB",$J,IBX)) Q:IBX=""!IBSTOP  S IBX2="" F  S IBX2=$O(^TMP("IBCECSB",$J,IBX,IBX2)) Q:IBX2=""!IBSTOP  S IBX3="" F  S IBX3=$O(^TMP("IBCECSB",$J,IBX,IBX2,IBX3)) Q:IBX3=""!IBSTOP  D  Q:IBSTOP
+ S IBX="" F  S IBX=$O(^TMP("IBCECSB",$J,IBX)) Q:IBX=""!IBSTOP  S IBX2="" F  S IBX2=$O(^TMP("IBCECSB",$J,IBX,IBX2)) Q:IBX2=""!IBSTOP  S IBX3="" F  S IBX3=$O(^TMP("IBCECSB",$J,IBX,IBX2,IBX3)) Q:IBX3=""!IBSTOP  D
  . I 'IBFST S IBPAY=$$IBPAY(IBX,IBX2,IBX3) D HDR1 S:'IBDIV IBFST=1 Q:IBSTOP
+ . S IBDA=0 F  S IBDA=$O(^TMP("IBCECSB",$J,IBX,IBX2,IBX3,IBDA)) Q:'IBDA!IBSTOP  S IB=$G(^TMP("IBCECSB",$J,IBX,IBX2,IBX3,IBDA)) D  Q:IBSTOP
+ .. I ($Y+3)>IOSL D HDR1 Q:IBSTOP
+ .. W $$BN1^PRCAFN(+IB),$P(IB,U,12),?13,$E($P(IB,U,2),1,25),?40,$E($P(IB,U,3),1,30),?72,$P($P(IB,U,4),"~"),?78,$$DAT1^IBOUTL($P(IB,U,5)),?88,$E($P(IB,U,7),1,10),?100,"$"_$J($P(IB,U,6),0,2),?110,$P(IB,U,10),?122,$P(IB,U,11),!
+ .. I $P(IB,U,12)="*" W " ***** CSA REVIEW IN PROCESS *****",!
+ . S IBDA=0 F  S IBDA=$O(^TMP("IBCECSB",$J,IBX,IBX2,IBX3,IBDA)) Q:'IBDA!IBSTOP  S IB=$G(^TMP("IBCECSB",$J,IBX,IBX2,IBX3,IBDA)) D
+ .. I ($Y+5)>IOSL D HDR1 Q:IBSTOP
+ .. W $$BN1^PRCAFN(+IB),?13,$E($P(IB,U,2),1,25),?40,$E($P(IB,U,3),1,30),?72,$P($P(IB,U,4),"~"),?78,$$DAT1^IBOUTL($P(IB,U,5)),?88,$E($P(IB,U,7),1,10),?100,"$"_$J($P(IB,U,6),0,2),?110,$P(IB,U,10),?122,$P(IB,U,11),!
  .. W " FORM TYPE: "_$P($G(^IBE(353,$P($G(^DGCR(399,+IB,0)),U,19),0)),U),!
  .. I 'IBDIV S X=" DIVISION: "_$P(IB,U,8) W X,$J(" ",40-$L(X))_"AUTHORIZING BILLER: "_$P($P(IB,U,9),"~",1),!
 …
  ... F I=1:131:$L(X) W " "_$E(X,I,I+130),!
  ... S IBZFT=1
+ ... I ($Y+3)>IOSL D HDR1 Q:IBSTOP
+ ... Q
+ .. Q:IBSTOP
+ .. ;
+ .. ; Display the Review Comments if they exist based on user choice (IB*377)
+ .. I $G(IBRVW),+$O(^IBM(361,IBDA,2,0)) D  Q:IBSTOP
+ ... N IBCM,IBT1,IBT0,IBD0,IBCL
+ ... I ($Y+3)>IOSL D HDR1 Q:IBSTOP
+ ... W ?3,"*** Review Comments for Claim "_$$BN1^PRCAFN(+IB)_" ***",!
+ ... S IBCM=0 F IBT1=0:1 S IBCM=$O(^IBM(361,IBDA,2,IBCM)) Q:'IBCM     ; count up # of comments
+ ... S IBT0=0
+ ... S IBCM=0 F  S IBCM=$O(^IBM(361,IBDA,2,IBCM)) Q:'IBCM!IBSTOP  D  Q:IBSTOP
+ .... S IBT0=IBT0+1
+ .... S IBD0=$G(^IBM(361,IBDA,2,IBCM,0))
+ .... I ($Y+3)>IOSL D HDR1 Q:IBSTOP
+ .... W ?7,"Entered "_$$FMTE^XLFDT($P(IBD0,U,1),"5ZPM")
+ .... I $P(IBD0,U,2) W " by "_$P($G(^VA(200,$P(IBD0,U,2),0)),U,1)
+ .... W " ("_IBT0_" of "_IBT1_")",!
+ .... S IBCL=0 F  S IBCL=$O(^IBM(361,IBDA,2,IBCM,1,IBCL)) Q:'IBCL!IBSTOP  D  Q:IBSTOP
+ ..... I ($Y+3)>IOSL D HDR1 Q:IBSTOP
+ ..... W ?10,$G(^IBM(361,IBDA,2,IBCM,1,IBCL,0)),!
+ ..... Q
+ .... Q
+ ... Q
+ .. ;
+ .. ; Display a line break before the next claim in this report
+ .. I ($Y+3)>IOSL D HDR1 Q:IBSTOP
+ ... I ($Y+5)>IOSL D HDR1 Q:IBSTOP
  .. W !
- .. Q
- . Q
+ ;
  G:IBSTOP LISTQ
  I $E(IOST,1,2)["C-" K DIR S DIR(0)="E" D ^DIR K DIR

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECSA4.m

-              r628
+              r636
 IBCECSA4 ;ALB/CXW - IB CLAIMS STATUS AWAITING RESOLUTION SCREEN ;5-AUG-1999
  ;;2.0;INTEGRATED BILLING;**137,155,320,371**;21-MAR-1994;Build 57
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**137,155,320**;21-MAR-1994
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
 SMSG ;select message
 …
  . D UNLOCK^IBCEU0(361,$P(IBA,U,2))
 SMSGQ S VALMBCK="R"
- I $G(IBFASTXT) S VALMBCK="Q" K IBDAX
  D:$O(IBDAX(0)) BLD^IBCECSA1
+ Q

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF.m

-              r628
+              r636
 IBCEF ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS ;22-JAN-96
  ;;2.0;INTEGRATED BILLING;**52,80,51,137,288,296,361,371**;21-MAR-94;Build 57
+ ;;2.0;INTEGRATED BILLING;**52,80,51,137,288,296,361**;21-MAR-94;Build 9
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
  S:$G(IBCOB)="" IBCOB=""
  I 'IBCOB S IBCOB=$$COBN(IBIFN,$G(IBCOB))
  S IBI=+$$POLICY(IBIFN,16,IBCOB)     ; pt relationship to insured
+ S IBI=+$$POLICY(IBIFN,16,IBCOB)
  S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2)
  I $S('IBI:1,1:"12"'[IBI) S IBADDR="" G INSADDQ
 …
 INSADDQ S A=$P($G(^DGCR(399,IBIFN,"M")),U,(11+IBCOB))
  S A=$G(^DPT(DFN,.312,+A,3))
+ I $TR($P(IBADDR,U)," ")="" D PI3
+ I IBI=2,$$NOPUNCT($P(A,U,6,10),1)'="" D PI3
+ I $TR($P(IBADDR,U)," ")="" D
+ .S $P(IBADDR,U)=$P(A,U,6)_" "_$P(A,U,7),$P(IBADDR,U,5,6)=$P(A,U,6,7)
+ .F B=2,4 S $P(IBADDR,U,B)=$P(A,U,B+6)
+ .S $P(IBADDR,U,3)=$P($G(^DIC(5,+$P(A,U,9),0)),U,2)
  Q IBADDR
+ ;
-PI3 ; build IBADDR string from patient insurance 3 node data
- S $P(IBADDR,U,1)=$P(A,U,6)_" "_$P(A,U,7)
- S $P(IBADDR,U,5,6)=$P(A,U,6,7)
- F B=2,4 S $P(IBADDR,U,B)=$P(A,U,B+6)
- S $P(IBADDR,U,3)=$P($G(^DIC(5,+$P(A,U,9),0)),U,2)
- S $P(IBADDR,U,7)=""   ; no street address 3 in file 2.312
+ Q
+ ;
 PTADDR(IBIFN,ELE) ;Return part of patient's permanent address

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF1.m

-              r628
+              r636
 IBCEF1 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS - CONT ;30-JAN-96
  ;;2.0;INTEGRATED BILLING;**52,124,51,137,210,155,349,371**;21-MAR-94;Build 57
+ ;;2.0;INTEGRATED BILLING;**52,124,51,137,210,155,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
  . ;       address that shows through the envelope window.
  . ;
+ . ; esg - 9/13/07 - IB*2*371 - Line 1 of this box contains the print
+ . ;       status (i.e. copy, 2nd notice, 3rd notice, MRA needed).
+ . ;
+ . N Z,Z1,LM,Q,ADDR,X,IBPSTAT
+ . N Z,LM,Q,ADDR,X
  . S LM=$P($G(^IBE(350.9,1,1)),U,31)   ; UB address column parameter
  . S Z=""
  . I LM S $P(Z," ",LM)=""              ; beginning spaces indent
  . S ADDR=$G(IBXSAVE("CADR"))          ; address data string
+ . ;
+ . D F^IBCEF("N-PRINT BILL SUBMIT STATUS","IBPSTAT",,+$G(IBXIEN))
+ . S Z1=Z I Z1="" S Z1=" "     ; line 1 can't start in column 1
+ . S IBXDATA(1)=Z1_$G(IBPSTAT),Q=1             ; line 1 print status
+ . S IBXDATA(1)="",Q=1                 ; line 1 is blank
  . S Q=Q+1
  . S IBXDATA(Q)=Z_$G(IBXSAVE("CADR_NAME"))     ; line 2 payer name

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF11.m

-              r628
+              r636
 IBCEF11 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS - CONT ;30-JAN-96
  ;;2.0;INTEGRATED BILLING;**51,137,155,309,335,348,349,371**;21-MAR-94;Build 57
+ ;;2.0;INTEGRATED BILLING;**51,137,155,309,335,348,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
  K IBRX
+ ;
- ; for EDI, remove any $0 line items from the IBFLD array before
- ; dropping down into the next loop (IB*2*371)
- I '$G(IBPRINT) D
- . NEW IBZ,IBI,Z
- . M IBZ=IBFLD K IBFLD
- . S (IBI,Z)=0
- . F  S IBI=$O(IBZ(24,IBI)) Q:IBI'=+IBI  D
- .. I $P(IBZ(24,IBI),U,7)*$P(IBZ(24,IBI),U,8)'>0 Q
- .. S Z=Z+1
- .. M IBFLD(24,Z)=IBZ(24,IBI)
- .. S IBFLD(24)=Z
- .. Q
- . Q
+ ;
  S IBI=0
  F  S IBI=$O(IBFLD(24,IBI)) Q:IBI'=+IBI  D
  . S IBRX1=0
+ . I '$G(IBPRINT) Q:$P(IBFLD(24,IBI),U,7)*$P(IBFLD(24,IBI),U,8)'>0  ; For EDI, ignore 0-charge line items
  . S IBXDATA(IBI)=$P(IBFLD(24,IBI),U)_U_$P(IBFLD(24,IBI),U,$S($P(IBFLD(24,IBI),U,2)=""&'$G(IBPRINT):1,1:2))
  . S $P(IBXDATA(IBI),U,3,5)=$P(IBFLD(24,IBI),U,3,5)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF21.m

-              r628
+              r636
 IBCEF21 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS CONTINUED ;06-FEB-96
+ ;;2.0;INTEGRATED BILLING;**51,296,371,389**;21-MAR-94;Build 6
+ ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**51,296**;21-MAR-94
+ ;
 COID(IBIFN) ; Claim office ID
 …
  D SET^IBCSC5B(IBIFN,.IBARRAY)
  I $P($G(IBARRAY),U,2) D  ;Prosthetics
  . S Z0=0 F  S Z0=$O(IBARRAY(Z0)) Q:Z0=""  S Z1=0 F  S Z1=$O(IBARRAY(Z0,Z1)) Q:'Z1  S Z=Z+1,IBXDATA(Z)="Prosthetic: "_$E($$PINB^IBCSC5B(+IBARRAY(Z0,Z1)),1,39)_" "_$E(Z0,4,5)_"/"_$E(Z0,6,7)_"/"_$E(Z0,1,2)
+ . S Z0=0 F  S Z0=$O(IBARRAY(Z0)) Q:Z0=""  S Z1=0 F  S Z1=$O(IBARRAY(Z0,Z1)) Q:'Z1  S Z=Z+1,IBXDATA(Z)="Prosthetic: "_$E($P($$PIN^IBCSC5B(Z1),U,2),1,39)_" "_$E(Z0,4,5)_"/"_$E(Z0,6,7)_"/"_$E(Z0,1,2)
+ Q
+ ;
 …
+ Q
+ ;
-INSSECID(IBIFN,TYPE,SEQ) ; Extract subscriber and patient prim/sec ID's
- ; IBIFN required
- ; TYPE is either "PAT" or "SUB" to indicate we need to extract either
- ;          patient or subscriber ID information.  Default="SUB".
- ; SEQ is the insurance sequence# (1,2,3).  Default is current ins seq#.
+ ;
- ; Output:
- ; Function returns an 8-piece string as follows.
- ;   [1] primary qualifier
- ;   [2] primary ID
- ;   [3] secondary qual(1)
- ;   [4] secondary ID(1)
- ;   [5] secondary qual(2)
- ;   [6] secondary ID(2)
- ;   [7] secondary qual(3)
- ;   [8] secondary ID(3)
+ ;
- NEW DATA,DFN,POL,IB0,IB5,REL
- S DATA=""
- S IBIFN=+$G(IBIFN) I 'IBIFN G INSSX
- I $G(TYPE)="" S TYPE="SUB"               ; default type of ID's to get
- I '$F(".PAT.SUB.","."_TYPE_".") G INSSX
- I '$G(SEQ) S SEQ=$$COBN^IBCEF(IBIFN)     ; default current ins seq#
- I '$F(".1.2.3.","."_SEQ_".") G INSSX
- S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2) I 'DFN G INSSX
- S POL=+$P($G(^DGCR(399,IBIFN,"M")),U,SEQ+11) I 'POL G INSSX
- S IB0=$G(^DPT(DFN,.312,POL,0)) I IB0="" G INSSX
- S IB5=$G(^DPT(DFN,.312,POL,5))
- S REL=+$P(IB0,U,16)                      ; pat rel to insured
- S $P(DATA,U,1)="MI"
- S $P(DATA,U,2)=$P(IB0,U,2)               ; subscriber primary ID
- S $P(DATA,U,3,8)=$P(IB5,U,2,7)           ; subscriber secondary data
- I TYPE="PAT",REL'=1 D
- . S $P(DATA,U,2)=$P(IB5,U,1)             ; patient primary ID
- . S $P(DATA,U,3,8)=$P(IB5,U,8,13)        ; patient secondary data
- . Q
+ ;
- S DATA=$$SCRUB(DATA)     ; scrub the data
-INSSX ;
- Q DATA
+ ;
-SCRUB(DATA) ; Scrub the 8-piece string gathered above
- NEW PCE
+ ;
- ; make sure you can't have an ID without a qualifier or a qualifier
- ; without an ID.  Check all 4 pairs.
- F PCE=1,3,5,7 D
- . I $P(DATA,U,PCE)'="",$P(DATA,U,PCE+1)'="" Q
- . S ($P(DATA,U,PCE),$P(DATA,U,PCE+1))=""
- . Q
+ ;
- ; fill in secondary gaps.  If Set1 and Set2 are blank, but Set3 exists
- ; then move Set3 to Set1 and delete Set3.
- I $P(DATA,U,3)="",$P(DATA,U,5)="",$P(DATA,U,7)'="" D
- . S $P(DATA,U,3)=$P(DATA,U,7),$P(DATA,U,4)=$P(DATA,U,8)
- . S ($P(DATA,U,7),$P(DATA,U,8))=""
- . Q
+ ;
- ; fill in secondary gaps more generically.
- ; If Set(n) is blank, but Set(n+1) exists, then move it up.
- F PCE=3,5 D
- . I $P(DATA,U,PCE)="",$P(DATA,U,PCE+2)'="" D
- .. S $P(DATA,U,PCE)=$P(DATA,U,PCE+2)
- .. S $P(DATA,U,PCE+1)=$P(DATA,U,PCE+3)
- .. S ($P(DATA,U,PCE+2),$P(DATA,U,PCE+3))=""
- .. Q
- . Q
+ ;
- Q DATA
+ ;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF22.m

r628	r636
1	1	IBCEF22 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS ;06-FEB-96
2		;;2.0;INTEGRATED BILLING;51,137,135,155,309,349~~,389;21-MAR-94;Build~~ 6
	2	;;2.0;INTEGRATED BILLING;51,137,135,155,309,349;21-MAR-94;Build 46
3	3	;;Per VHA Directive 2004-038, this routine should not be modified.
4	4	;
…	…
122	122	.. S IBLCNT=IBLCNT+1,IBXSAVE("PROS-UB-04",IBLCNT)="PROSTHETIC REFILLS:",IBLCNT=2
123	123	.. S IBX=0 F S IBX=$O(IBARRAY(IBX)) Q:IBX="" S IBY=0 F S IBY=$O(IBARRAY(IBX,IBY)) Q:'IBY D
124		... S IBLCNT=IBLCNT+1,IBXSAVE("PROS-UB-04",IBLCNT)=$$FMTE^XLFDT(IBX,2)_" "_$J($S($P(IBARRAY(IBX,IBY),U,2):"$"_$FN($P(IBARRAY(IBX,IBY),U,2),",",2),1:""),10)_" "_$E($~~$PINB^IBCSC5B(+IBARRAY(IBX,IBY)~~),1,54)
	124	... S IBLCNT=IBLCNT+1,IBXSAVE("PROS-UB-04",IBLCNT)=$$FMTE^XLFDT(IBX,2)_" "_$J($S($P(IBARRAY(IBX,IBY),U,2):"$"_$FN($P(IBARRAY(IBX,IBY),U,2),",",2),1:""),10)_" "_$E($P($$PIN^IBCSC5B(IBY),U,2),1,54)
125	125	Q
126	126	;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF3.m

-              r628
+              r636
 IBCEF3 ;ALB/TMP - FORMATTER SPECIFIC BILL FLD FUNCTIONS ;17-JUNE-96
  ;;2.0;INTEGRATED BILLING;**52,84,121,51,152,210,155,348,349,389**;21-MAR-94;Build 6
+ ;;2.0;INTEGRATED BILLING;**52,84,121,51,152,210,155,348,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
  S Z="",CT=0
  F  S Z=$O(IBARRAY(Z)) Q:Z=""  S Z0="" F  S Z0=$O(IBARRAY(Z,Z0)) Q:Z0=""  S CT=CT+1 D
  .S PROS=$$PINB^IBCSC5B(+IBARRAY(Z,Z0)) ; P389 removed p2 - item ptr file 661
  .;date^^short descr^entry # in file 362.5
  .S IBXDATA(CT)=Z_U_U_PROS_U_+IBARRAY(Z,Z0)
+ .S PROS=$P($$PIN^IBCSC5B(+$P($G(^IBA(362.5,+IBARRAY(Z,Z0),0)),U,3)),U,2)
+ .;date^item ptr file 661^short descr from file 441^entry # in file 362.5
+ .S IBXDATA(CT)=Z_U_Z0_U_PROS_U_+IBARRAY(Z,Z0)
 PROSQ Q CT
+ ;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF73.m

-              r628
+              r636
 IBCEF73 ;WOIFO/SS - FORMATTER AND EXTRACTOR SPECIFIC BILL FUNCTIONS ;8/6/03 10:56am
  ;;2.0;INTEGRATED BILLING;**232,320,358,349,377**;21-MAR-94;Build 23
+ ;;2.0;INTEGRATED BILLING;**232,320,358,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
  D F^IBCEF("N-ALL INSURED PT RELATION","IBZ",,IBXIEN)
  S IBZ=$G(IBZ(+$$COBN^IBCEF(IBXIEN)))
  S IBZ=$$PRELCNV^IBCNSP1(IBZ,1)
+ S IBZ=$$RELATION^IBCEFG1(IBZ)
  I IBZ'="18" S IBXDATA="" Q
  N IBZ D F^IBCEF("N-PATIENT STREET ADDRESS 1-3","IBZ",,IBXIEN)
 …
  . S IBIDTYP=$P($G(^IBE(355.97,IBIDTYP,0)),"^",3)
  . S:IBIDTYP="EI" IBID=$P($G(^IBA(355.9,IB3559,0)),"^",7),IBQFL=1
- ; if nothing found yet, look in file 355.93 for Facility Default ID
- I IBID="",IBPROV["IBA(355.93" D
- .N IB0,IBFID,IBQ
- .S IB0=$G(^IBA(355.93,+IBPROV,0)) Q:IB0=""!($P(IB0,U,2)'=1)  ; not a facility - bail out
- .S IBFID=$P(IB0,U,9) Q:IBFID=""  ; no default id on file - bail out
- .S IBQ=$P(IB0,U,13) I +IBQ>0,$P($G(^IBE(355.97,IBQ,0)),U,3)=24 S IBID=IBFID
- .Q
  Q $$NOPUNCT^IBCEF(IBID)
+ ;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF73A.m

-              r628
+              r636
 IBCEF73A ;ALB/KJH - FORMATTER AND EXTRACTOR SPECIFIC (NPI) BILL FUNCTIONS ; 30 Aug 2006  10:38 AM
  ;;2.0;INTEGRATED BILLING;**343,374,395**;21-MAR-94;Build 3
+ ;;2.0;INTEGRATED BILLING;**343,374**;21-MAR-94;Build 16
  ;; Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
 …
  I IBORG S NPI=$P($$NPI^XUSNPI("Organization_ID",IBORG),U) S:NPI'=-1 $P(IBRETVAL,U,3)=NPI
  I NPI<1,$D(IBNONPI) S IBNONPI=$S(IBNONPI="":3,1:IBNONPI_U_3)
- I $$ISRX^IBCEF1(IBIEN399) S IBORG=$$RXSITE(IBIEN399) I IBORG S NPI=$P($$NPI^XUSNPI("Organization_ID",IBORG),U) S:NPI'=-1 $P(IBRETVAL,U,3)=NPI
  Q IBRETVAL
+ ;
 …
  I '$L(TAX),$D(IBNOTAX) S IBNOTAX=$S(IBNOTAX="":3,1:IBNOTAX_U_3)
  Q IBRETVAL
+ ;
-RXSITE(IBIEN399,IBLIST) ; returns prescription organization (file 4) pointer
- ; for the given bill.  If IBLIST passed by reference, then a list of
- ; the possible organizations are returned for a bill, since a bill may
- ; have more than one prescription.  If more than one rx on the bill, the
- ; $$ return is the pointer of the last prescription found.
- ; IBLIST(rx ien,fill date)=ORGINATION (file 4 pointer)
+ ;
- N IBX,IBDATA,IBORG,IBRX,IBDT,IBY,IBRXN,DFN
- K ^TMP($J,"IBCEF73A")
- S IBORG=0,DFN=$P($G(^DGCR(399,IBIEN399,0)),"^",2),IBLIST="IBCEF73A"
- S IBRXN=0 F  S IBRXN=$O(^IBA(362.4,"AIFN"_IBIEN399,IBRXN)) Q:'IBRXN  S IBX=0 F  S IBX=$O(^IBA(362.4,"AIFN"_IBIEN399,IBRXN,IBX)) Q:'IBX  D
- . S IBDATA=$G(^IBA(362.4,IBX,0))
- . S IBRX=$P(IBDATA,"^",5),IBDT=$P(IBDATA,"^",3) Q:'IBRX!('IBDT)
- . D RX^PSO52API(DFN,IBLIST,IBRX,,"0,2,R")
- . I IBDT=+$G(^TMP($J,"IBCEF73A",DFN,IBRX,22)) S (IBORG,IBLIST(IBRX,IBDT))=$$PSONPI(+$G(^TMP($J,"IBCEF73A",DFN,IBRX,20))) Q
- . S IBY=0 F  S IBY=$O(^TMP($J,"IBCEF73A",DFN,IBRX,"RF",IBY)) Q:'IBY  I IBDT=+$G(^TMP($J,"IBCEF73A",DFN,IBRX,"RF",IBY,.01)) S (IBORG,IBLIST(IBRX,IBDT))=$$PSONPI(+$G(^TMP($J,"IBCEF73A",DFN,IBRX,"RF",IBY,8))) Q
- K ^TMP($J,"IBCEF73A")
- Q IBORG
+ ;
-PSONPI(IB59IEN) ; returns institution ien for a file 59 ien
- N IB4IEN
- K ^TMP($J,"IBCEF59")
- D PSS^PSO59(IB59IEN,,"IBCEF59")
- S IB4IEN=+$G(^TMP($J,"IBCEF59",IB59IEN,101))
- K ^TMP($J,"IBCEF59")
- Q IB4IEN

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF74A.m

-              r628
+              r636
 IBCEF74A ;ALB/ESG - Provider ID maint ?ID continuation ;7 Mar 2006
  ;;2.0;INTEGRATED BILLING;**320,343,349,395**;21-MAR-94;Build 3
+ ;;2.0;INTEGRATED BILLING;**320,343,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
  S IBXIEN=IBIFN
  D F^IBCEF("N-RENDERING INSTITUTION","IBZ",,IBIFN)
- I $$ISRX^IBCEF1(IBIFN) S Z=$$RXSITE^IBCEF73A(IBIFN) I Z S $P(IBZ,"^")=+Z
  S FACNAME=$$GETFAC^IBCEP8(+IBZ,+$P(IBZ,U,2),0,"SUB")
  S Z="LAB/FAC"
 …
  ; PRXM/KJH - Add NPI to display for patch 343.
  S ORGNPI=$$ORGNPI^IBCEF73A(IBIFN)
  S DATA=$S($$ISRX^IBCEF1(IBIFN):$P(ORGNPI,U,3),$P($G(IBZ),U,2)=1:$P(ORGNPI,U,2),$P($G(IBZ),U,2)=0:$P(ORGNPI,U,1),1:$P(ORGNPI,U,3))
+ S DATA=$S($P($G(IBZ),U,2)=1:$P(ORGNPI,U,2),$P($G(IBZ),U,2)=0:$P(ORGNPI,U,1),1:$P(ORGNPI,U,3))
  I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
  W !?5,"Lab or Facility NPI:"

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF75.m

-              r628
+              r636
 IBCEF75 ;ALB/WCJ - Provider ID functions ;13 Feb 2006
  ;;2.0;INTEGRATED BILLING;**320,371**;21-MAR-94;Build 57
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**320**;21-MAR-94
+ ;; Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
  G AWAY
 …
  ; Secondary #2
  ; If there is a ID  send with quailifer (stored or computed)
  I $TR($P(M1,U,COB+1)," ")]"" D
+ I $P(M1,U,COB+1)]"" D
  . S QUAL=""
  . S DAT=$P(M1,U,COB+9)
 …
  . S IB2=QUAL_U_$$STRIP^IBCEF76($P(M1,U,COB+1),1,,IBSTRIP)
+ ;
  I $TR($P(M1,U,COB+1)," ")="" S IB2=$$STRIP^IBCEF76($$OLDWAY(IBIFN,COB),1,,IBSTRIP)_U_$$STRIP^IBCEF76($$GET1^DIQ(350.9,1,1.05),1,,IBSTRIP)
+ I $P(M1,U,COB+1)="" S IB2=$$STRIP^IBCEF76($$OLDWAY(IBIFN,COB),1,,IBSTRIP)_U_$$STRIP^IBCEF76($$GET1^DIQ(350.9,1,1.05),1,,IBSTRIP)
+ ;
  S IDS("BILLING PRV",IBIFN,SORT1,SORT2,2)=IB2

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEFG1.m

-              r628
+              r636
 IBCEFG1 ;ALB/TMP - OUTPUT FORMATTER DATA DEFINITION UTILITIES ;18-JAN-96
  ;;2.0;INTEGRATED BILLING;**52,51,137,181,197,232,288,349,371,377**;21-MAR-94;Build 23
+ ;;2.0;INTEGRATED BILLING;**52,51,137,181,197,232,288,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
  ; the decimal and commas.
  N DOLR,CENT
  I AMT'="" S AMT=$TR(AMT,","),DOLR=$P(AMT,"."),CENT=$E($P(AMT,".",2)_"00",1,2),AMT=DOLR_CENT
  Q AMT
+ I AMT'="" S DOLR=$P(AMT,"."),CENT=$E($P(AMT,".",2)_"00",1,2),AMT=DOLR_CENT
+ Q $TR(AMT,",")
+ ;
 STATE(CODE) ;Return state code from state pointer
 …
  ; CODE = DHCP code for sex
  Q $S(CODE="":"U","MF"[$E(CODE):$E(CODE),1:"U")
+ ;
+RELATION(CODE) ;Return the X12 code for relationship
+ ; CODE = DHCP code for relationship
+ N X12
+ S X12=""
+ S:CODE'="" X12=$P($S(CODE="01":"18^SELF",CODE="02":"01^SPOUSE",CODE="03":"19^NATURAL CHILD",CODE="08":"20^EMPLOYEE",CODE="32":"32^MOTHER",CODE="33":"33^FATHER",CODE="11":"39^ORGAN DONOR",CODE="15":"41^INJURED PLAINTIFF",1:""),U)
+ Q X12
+ ;
 EMPLST(CODE) ;Return the X12 code for employment status

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEM.m

r628	r636
1	1	IBCEM ;ALB/TMP - 837 EDI RETURN MESSAGE PROCESSING ;17-APR-96
2		;;2.0;INTEGRATED BILLING;137,191,155,371;21-MAR-94;Build 57
3		;;Per VHA Directive 2004-038, this routine should not be modified.
	2	;;2.0;INTEGRATED BILLING;137,191,155;21-MAR-94
4	3	Q
5	4	;
…	…
88	87	;
89	88	S IBTEXT(1)=" UPDATED BY: "_$$EXTERNAL^DILFD(361.02,.02,,+$G(DUZ))
90		S IBTEXT(2)="ACTION USED: "_$S(FUNC="E":"BILL EDITED/RESUBMITTED",FUNC="C":"BILL CANCELED",FUNC="R":"BILL RESUBMITTED WITHOUT EDIT",FUNC="P":"PRINT BILL",FUNC="Z":"PROCESS COB",1:"")
	89	S IBTEXT(2)="ACTION USED: "_$S(FUNC="E":"BILL EDITED/RESUBMITTED",FUNC="C":"BILL CANCELED",FUNC="R":"BILL RESUBMITTED WITHOUT EDIT)",FUNC="P":"PRINT BILL",FUNC="Z":"PROCESS COB",1:"")
91	90	S IBTEXT(2)=$S(IBTEXT(2)="":"UNSPECIFIED",1:IBTEXT(2)_" - REVIEW MARKED AS COMPLETE")
92	91	S IBTEXT=2

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEM4.m

-              r628
+              r636
 IBCEM4 ;ALB/TMP - IB ELECTRONIC MESSAGE SCREEN TEXT MAINT ;19-APR-2001
  ;;2.0;INTEGRATED BILLING;**137,368**;21-MAR-1994;Build 21
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**137**;21-MAR-1994
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
 EN ; entry point for maintenance
 …
+ ;
  N T,Y,Z,Z0
  S (IBREV,Y)=0,Z="",IBTEXT=$$UP^XLFSTR($G(IBTEXT))
  I '$G(IBSKIP) F  S Z=$O(^IBE(361.3,"AC",1,Z)) Q:Z=""  I IBTEXT[$$UP^XLFSTR(Z) S IBREV=1 Q  ; Always review messages with this text
  I 'IBREV S Z="" F  S Z=$O(^IBE(361.3,"AC",0,Z)) Q:Z=""  I IBTEXT[$$UP^XLFSTR(Z) S Y=1,IBNR=Z Q  ; Message contains text to make review unnecessary
+ S (IBREV,Y)=0,Z=""
+ I '$G(IBSKIP) F  S Z=$O(^IBE(361.3,"AC",1,Z)) Q:Z=""  I IBTEXT[Z S IBREV=1 Q  ; Always review messages with this text
+ I 'IBREV S Z="" F  S Z=$O(^IBE(361.3,"AC",0,Z)) Q:Z=""  I IBTEXT[Z S Y=1,IBNR=Z Q  ; Message contains text to make review unnecessary
  Q Y
+ ;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEMCA2.m

-              r628
+              r636
 IBCEMCA2 ;ALB/ESG - Multiple CSA Message Management - Actions ;20-SEP-2005
  ;;2.0;INTEGRATED BILLING;**320,377**;21-MAR-1994;Build 23
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**320**;21-MAR-1994
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
+ Q
 …
 CANCEL ; mass claim cancel
  NEW NS,IBIFN,NSC,DIR,X,Y,DUOUT,DTOUT,DIRUT,DIROUT,IBDA,IB364,DISP,IBCE
  NEW IBMCSRSC,IBMCSRNB,IBMCSCNT,IBMCSTOT,IBMCSTOP,IBMCSCAN,MRACHK,IBCAN,IBMCSCAC
+ NEW IBMCSRSC,IBMCSRNB,IBMCSCNT,IBMCSTOT,IBMCSTOP,IBMCSCAN,MRACHK,IBCAN
  D FULL^VALM1
+ ;
 …
  W !!,"In order to cancel "
  W $S(NSC=1:"this claim",1:"these claims")
+ W ", a Reason Cancelled and a Reason Not Billable"
+ W !,"are required.  You may also provide an optional CT Additional Comment."
+ W !,"These will be used as the default responses for "
+ W ", you must supply the Reason Cancelled and"
+ W !,"the Reason Not Billable.  These will be the default responses for "
  W $S(NSC=1:"this claim",1:"all claims")
  W "."
 …
  I $D(DIRUT) G CANCELX
  M IBMCSRNB=Y           ; save the reason not billable code/desc
+ ;
-CANQ3 ; reader call for the Claims Tracking Additional Comment field
- W !
- S DIR(0)="356,1.08O"
- S DIR("A")="CT Additional Comment"
- D ^DIR K DIR
- I $D(DIRUT) G CANCELX
- M IBMCSCAC=Y
+ ;
  W !

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEOB.m

-              r628
+              r636
 IBCEOB ;ALB/TMP - 835 EDI EOB MESSAGE PROCESSING ;20-JAN-99
+ ;;2.0;INTEGRATED BILLING;**137,135,265,155,377**;21-MAR-94;Build 23
+ ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+ ;;2.0;INTEGRATED BILLING;**137,135,265,155**;21-MAR-94
+ Q
+ ;
 …
  ; Duplicate EOB Check
  S IBFILE="^IBA(364.2,"_IBTDA_",2)"
  I $$DUP(IBFILE,X) D DELMSG^IBCESRV2(IBTDA) G UPDQ
+ I $$DUP(IBFILE,X) G UPDQ
+ ;
  I '$$LOCK^IBCEM(IBTDA) G UPDQ ;Lock msg file 364.2
 …
 (IB0,IBEGBL,IBEOB) ; Record '05'
+ ;
  N IBOK,DA,DR,DIE,X,Y
+ N IBOK,IBBULL,DA,DR,DIE,X,Y
  K IBZDATA
  S DR=";",IBOK=1
  S DIE="^IBM(361.1,",DA=IBEOB
+ ;
+ I $P(IB0,U,9) S DR=DR_"1.1///"_$$DATE^IBCEU($P(IB0,U,9))_";"         ; statement start date
+ I $P(IB0,U,10) S DR=DR_"1.11///"_$$DATE^IBCEU($P(IB0,U,10))_";"      ; statement end date
+ S IBBULL=""
+ I $$UPDNM^IBCEOB00(IBEOB,IB0,.IBBULL,.DR)!$$UPDID^IBCEOB00(IBEOB,IB0,.IBBULL,.DR) D  ; New insured's name and/or HIC # found
+ . D CHGBULL^IBCEOB3(IBEOB,IBBULL) ;Send a bulletin reporting change
+ ;
+ I $P(IB0,U,9) S DR=DR_"1.1///"_$$DATE^IBCEU($P(IB0,U,9))_";"
+ I $P(IB0,U,10) S DR=DR_"1.11///"_$$DATE^IBCEU($P(IB0,U,10))_";"
  S DR=$P(DR,";",2,$L(DR,";")-1)
  I DR'="" D ^DIE S IBOK=$D(Y)=0
  I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad record 5 data"
  Q IBOK
+ ;
-(IB0,IBEGBL,IBEOB) ; Record '06' - corrected patient name and/or ID#
- ; This data is not going to be filed into file 361.1 so the value of this function will always be a 1 so as to
- ; not interrupt the filing process of the EOB/MRA data into file 361.1.
+ ;
- ; perform overall integrity checks on the incoming 06 record.  If anything is out of place, don't update anything
- ; and report the problem and get out.
- NEW CLM,SITE,IBM,IBIFN,IBIFN1,DFN,SEQ,DIE,DA,DR
- S DIE=361.1,DA=IBEOB,DR="61.01////^S X=IB0" D ^DIE    ; archive the raw 06 record data
- S CLM=$P(IB0,U,2),SITE=+CLM,CLM=$P(CLM,"-",2) I CLM="" D MSG(IBEOB,"The claim# in piece 2 is invalid.") G Q6
- S IBM=$G(^IBM(361.1,IBEOB,0))
- I $P(IBM,U,4)'=1 D MSG(IBEOB,"This is a non-Medicare EOB.") G Q6
- S IBIFN=+$P(IBM,U,1)                    ; claim# from MRA
- S IBIFN1=+$O(^DGCR(399,"B",CLM,""))     ; claim# from 06 record
- I IBIFN'=IBIFN1 D MSG(IBEOB,"Claim mismatch error."_IBIFN_","_IBIFN1_","_CLM_".") G Q6
- I $P($$SITE^VASITE,U,3)'=SITE D MSG(IBEOB,"Invalid station# mismatch."_$P($$SITE^VASITE,U,3)_","_SITE_".") G Q6
- S SEQ=$$COBN^IBCEF(IBIFN)               ; current payer sequence# on claim
- I '$$WNRBILL^IBEFUNC(IBIFN,SEQ) D MSG(IBEOB,"The current payer on this claim is not MEDICARE (WNR).") G Q6
- S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2)   ; patient ien
- I 'DFN D MSG(IBEOB,"The patient DFN cannot be determined.") G Q6
+ ;
- D UPD^IBCEOB01(IB0,IBEOB,IBIFN,DFN,SEQ)     ; update patient insurance policy data
+ ;
-Q6 ; exit point for $$6 function
- Q 1
+ ;
 (IB0,IBEGBL,IBEOB) ; Record '10'
 …
+ ;
 (IB0,IBEGBL,IBEOB) ; Record '15'
+ ; Moved due to space constraints
+Q15 Q $$15^IBCEOB00(IB0,IBEGBL,IBEOB)
+ ;
+ N A,IBOK
+ ;
+ S A="3;1.03;1;0;0^4;1.04;1;0;0^5;1.05;1;0;0^6;1.07;1;0;0^7;1.08;1;0;0^8;1.09;1;0;0^9;1.02;1;0;0^10;2.05;1;0;0"
+ ;
+ S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB)
+ I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad record 15 data" G Q15
+ ;
+ ; For Medicare MRA's only:
+ ; If the Covered Amount is present (15 record, piece 3), then file
+ ; a claim level adjustment with Group code=OA, Reason code=AB3.
+ ;
+ I $P($G(^IBM(361.1,IBEOB,0)),U,4)=1,+$P(IB0,U,3) D
+ . N IB20
+ . S IB20=20_U_$P(IB0,U,2)_U_"OA"_U_"AB3"_U_$P(IB0,U,3)_U_"0000000000"
+ . S IB20=IB20_U_"Covered Amount"
+ . S IBOK=$$20(IB20,IBEGBL,IBEOB)
+ . I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Could not file the OA-AB3 claim level adjustment for the Covered Amount"
+ . K ^TMP($J,20)
+ . Q
+ ;
+Q15 Q IBOK
+ ;
 (IB0,IBEGBL,IBEOB) ; Record '17'
 …
+ ;
 (IB0,IBEGBL,IBEOB) ; Record '20'
+ ; Moved due to space constraints
+Q20 Q $$20^IBCEOB00(IB0,IBEGBL,IBEOB)
+ ;
+ N A,LEVEL,IBGRP,IBDA,IBOK
+ ;
+ S IBGRP=$P(IB0,U,3)
+ I IBGRP'="" S ^TMP($J,20)=IBGRP
+ I IBGRP="" S IBGRP=$G(^TMP($J,20))
+ I IBGRP="" S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Missing claim level adjustment group code" G Q20
+ ;
+ S IBDA(1)=$O(^IBM(361.1,IBEOB,10,"B",IBGRP,0))
+ ;
+ I 'IBDA(1) D  ;Needs a new entry at group level
+ . N X,Y,DA,DD,DO,DIC,DLAYGO
+ . S DIC="^IBM(361.1,"_IBEOB_",10,",DIC(0)="L",DLAYGO=361.11,DA(1)=IBEOB
+ . S DIC("P")=$$GETSPEC^IBEFUNC(361.1,10)
+ . S X=IBGRP
+ . D FILE^DICN K DIC,DO,DD,DLAYGO
+ . I Y<0 K IBDA S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Adjustment group code could not be added" Q
+ . S IBDA(1)=+Y
+ ;
+ I $G(IBDA(1)) D  ;Add a new entry at the reason code level
+ . S DIC="^IBM(361.1,"_IBEOB_",10,"_IBDA(1)_",1,",DIC(0)="L",DLAYGO=361.111,DA(2)=IBEOB,DA(1)=IBDA(1)
+ . S DIC("P")=$$GETSPEC^IBEFUNC(361.11,1)
+ . S X=$P(IB0,U,4)
+ . D FILE^DICN K DIC,DO,DD,DLAYGO
+ . I Y<0 K IBDA S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Adjustment reason code could not be added" Q
+ . S IBDA=+Y
+ ;
+ I $G(IBDA) D
+ . S LEVEL=10,LEVEL("DIE")="^IBM(361.1,"_IBEOB_",10,"_IBDA(1)_",1,"
+ . S LEVEL(0)=IBDA,LEVEL(1)=IBDA(1),LEVEL(2)=IBEOB
+ . S A="5;.02;1;0;0^6;.03;0;1;1^7;.04;0;1;0"
+ . S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB,.LEVEL)
+ . I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad adjustment reason code ("_$P(IB0,U,4)_") data" Q
+Q20 Q $G(IBOK)
+ ;
 (IB0,IBEGBL,IBEOB) ; Record '30'
 …
  D 45^IBCEOB0(IB0,IBEOB,.IBOK)
  Q $G(IBOK)
+ ;
-MSG(IBEOB,MSG) ; procedure to file message into field 6.03
- ; Results of processing of the "06" record type
- N DIE,DA,DR,Z
- S DIE=361.1,DA=+$G(IBEOB)
- I $G(MSG)="" G MSGX
- S Z=$P($G(^IBM(361.1,DA,6)),U,3)    ; already existing message
- I Z'="" S MSG=Z_"  "_MSG            ; append new message to existing message
- S MSG=$E(MSG,1,190)
- S DR="6.03///^S X=MSG"
- D ^DIE
-MSGX ;
+ Q
+ ;
 DOLLAR(X) ; Convert value in X to dollar format XXX.XX
 …
  ; IBFILE = array reference of raw EOB data
+ ;
  N DIC,DA,DR,DO,DD,DLAYGO,Y,REVSTAT,BS,MMI
+ N DIC,DA,DR,DO,DD,DLAYGO,Y,REVSTAT,BS
  F  L +^IBM(361.1,0):10 Q:$T
+ ;
 …
  S BS=$P($G(^DGCR(399,X,0)),U,13)   ; bill status
  S REVSTAT=$S(BS=7:9,BS=3:3,BS=4:3,1:0)
- S MMI=$$NET^XMRENT(IBMNUM)         ; MailMan header info
  S DIC(0)="L",DIC="^IBM(361.1,",DLAYGO=361.1
  S DIC("DR")=".16////"_REVSTAT_";.17////0"_";100.02////"_IBMNUM_$S('$G(IBAR):";.19////"_+IBTBILL_";100.01////"_IBBATCH,1:"")
  S DIC("DR")=DIC("DR")_";100.05////"_$$CHKSUM^IBCEMU1(IBFILE)_";62.01////^S X=MMI"
+ S DIC("DR")=DIC("DR")_";100.05////"_$$CHKSUM^IBCEMU1(IBFILE)
  D FILE^DICN
  L -^IBM(361.1,0)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEOB00.m

-              r628
+              r636
 IBCEOB00 ;ALB/ESG - 835 EDI EOB MSG PROCESSING CONT ;30-JUN-2003
  ;;2.0;INTEGRATED BILLING;**155,349,377**;21-MAR-94;Build 23
+ ;;2.0;INTEGRATED BILLING;**155,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ Q
 …
 ICNX ;
+ Q
+ ;
-(IB0,IBEGBL,IBEOB) ; Record '15'
+ ;
- N A,IBOK
+ ;
- S A="3;1.03;1;0;0^4;1.04;1;0;0^5;1.05;1;0;0^6;1.07;1;0;0^7;1.08;1;0;0^8;1.09;1;0;0^9;1.02;1;0;0^10;2.05;1;0;0"
+ ;
- S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB)
- I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad record 15 data" G Q15
+ ;
- ; For Medicare MRA's only:
- ; If the Covered Amount is present (15 record, piece 3), then file
- ; a claim level adjustment with Group code=OA, Reason code=AB3.
+ ;
- I $P($G(^IBM(361.1,IBEOB,0)),U,4)=1,+$P(IB0,U,3) D
- . N IB20
- . S IB20=20_U_$P(IB0,U,2)_U_"OA"_U_"AB3"_U_$P(IB0,U,3)_U_"0000000000"
- . S IB20=IB20_U_"Covered Amount"
- . S IBOK=$$20(IB20,IBEGBL,IBEOB)
- . I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Could not file the OA-AB3 claim level adjustment for the Covered Amount"
- . K ^TMP($J,20)
- . Q
+ ;
-Q15 Q IBOK
+ ;
-(IB0,IBEGBL,IBEOB) ; Record '20'
+ ;
- N A,LEVEL,IBGRP,IBDA,IBOK
+ ;
- S IBGRP=$P(IB0,U,3)
- I IBGRP'="" S ^TMP($J,20)=IBGRP
- I IBGRP="" S IBGRP=$G(^TMP($J,20))
- I IBGRP="" S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Missing claim level adjustment group code" G Q20
+ ;
- S IBDA(1)=$O(^IBM(361.1,IBEOB,10,"B",IBGRP,0))
+ ;
- I 'IBDA(1) D  ;Needs a new entry at group level
- . N X,Y,DA,DD,DO,DIC,DLAYGO
- . S DIC="^IBM(361.1,"_IBEOB_",10,",DIC(0)="L",DLAYGO=361.11,DA(1)=IBEOB
- . S DIC("P")=$$GETSPEC^IBEFUNC(361.1,10)
- . S X=IBGRP
- . D FILE^DICN K DIC,DO,DD,DLAYGO
- . I Y<0 K IBDA S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Adjustment group code could not be added" Q
- . S IBDA(1)=+Y
+ ;
- I $G(IBDA(1)) D  ;Add a new entry at the reason code level
- . S DIC="^IBM(361.1,"_IBEOB_",10,"_IBDA(1)_",1,",DIC(0)="L",DLAYGO=361.111,DA(2)=IBEOB,DA(1)=IBDA(1)
- . S DIC("P")=$$GETSPEC^IBEFUNC(361.11,1)
- . S X=$P(IB0,U,4)
- . D FILE^DICN K DIC,DO,DD,DLAYGO
- . I Y<0 K IBDA S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Adjustment reason code could not be added" Q
- . S IBDA=+Y
+ ;
- I $G(IBDA) D
- . S LEVEL=10,LEVEL("DIE")="^IBM(361.1,"_IBEOB_",10,"_IBDA(1)_",1,"
- . S LEVEL(0)=IBDA,LEVEL(1)=IBDA(1),LEVEL(2)=IBEOB
- . S A="5;.02;1;0;0^6;.03;0;1;1^7;.04;0;1;0"
- . S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB,.LEVEL)
- . I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad adjustment reason code ("_$P(IB0,U,4)_") data" Q
-Q20 Q $G(IBOK)
+ ;
 (IB0,IBEGBL,IBEOB) ; Record '35'
 …
  Q X
+ ;
+UPDNM(IBEOB,IB0,IBBULL,IBDR) ; Update name on claim if it comes back changed
+ ; IBEOB = the internal entry # of the entry in file 361.1
+ ; IB0 = the raw data returned from the 835 flat file
+ ; IBBULL = holds result of name change check in piece 1 - if name
+ ;          changed, first '^' piece is 1, 3rd '^' piece is the old
+ ;          insured's name
+ ; IBDR = returned as the updated 'DR' string with the name changed
+ ;       fields to use to update the EOB file (361.1) - pass by reference
+ ;
+ N IBCHGED,IBIFN,IBNEW,IBCOB,DIE,DR,X,Y
+ I $P(IB0,U,7) D
+ . S IBNEW=$P(IB0,U,3)_","_$P(IB0,U,4)_$S($P(IB0,U,5)'="":" "_$P(IB0,U,5),1:""),$P(IBBULL,U)=1
+ . S IBCOB=+$P($G(^IBM(361.1,IBEOB,0)),U,15)
+ . S IBIFN=+$G(^IBM(361.1,+IBEOB,0))
+ . S IB=$G(^DGCR(399,IBIFN,"I"_IBCOB))
+ . ;
+ . I IB'="",$P(IB,U,17)'=IBNEW D
+ .. ; Update the claim data only
+ .. S $P(IBBULL,U,3)=$P(IB,U,17) ; save old value
+ .. S $P(IB,U,17)=IBNEW
+ .. S DIE="^DGCR(399,",DA=IBIFN,DR="30"_IBCOB_"////"_IB
+ .. D:DA ^DIE
+ .. S IBCHGED=1
+ . S IBDR=$G(IBDR)_"6.01////"_$P(IB0,U,3)_","_$P(IB0,U,4)_" "_$P(IB0,U,5)_";"
+ ;
+ Q $G(IBCHGED)
+ ;
+UPDID(IBEOB,IB0,IBBULL,IBDR) ; Update id # on claim and policy if it comes back
+ ;   changed
+ ; IBEOB = the internal entry # of the entry in file 361.1
+ ; IB0 = the raw data returned from the 835 flat file
+ ; IBBULL = holds result of id change check in piece 2 - if id changed,
+ ;          second '^' piece = 1,4th '^' piece is the old insured's id
+ ; IBDR = returned as the updated 'DR' string with the id changed fields
+ ;        to use to update the EOB file (361.1) - pass by reference
+ ;
+ N IBCHGED,IBNEW,IBCOB,IB,DIE,DR,DA,X,Y
+ I $P(IB0,U,8) D
+ . S IBNEW=$P(IB0,U,6),$P(IBBULL,U,2)=1
+ . S IBIFN=+$G(^IBM(361.1,+IBEOB,0))
+ . S IBCOB=+$P($G(^IBM(361.1,IBEOB,0)),U,15)
+ . S IB=$G(^DGCR(399,IBIFN,"I"_IBCOB))
+ . ;
+ . I IB'="",$P(IB,U,2)'=IBNEW D
+ .. ; Update the claim
+ .. S $P(IBBULL,U,4)=$P(IB,U,2) ; save old value
+ .. S $P(IB,U,2)=IBNEW
+ .. S DIE="^DGCR(399,",DA=IBIFN,DR="30"_IBCOB_"////"_IB D ^DIE
+ .. ;
+ .. ; Update the policy
+ .. S DA(1)=$P($G(^DGCR(399,IBIFN,0)),U,2),DA=$P($G(^("M")),U,(11+IBCOB)),DR="1////"_IBNEW,DIE="^DPT("_DA(1)_",.312,"
+ .. I DA(1),DA D ^DIE
+ .. S IBCHGED=1
+ . S IBDR=$G(IBDR)_"6.02////"_$P(IB0,U,6)_";"
+ ;
+ Q $G(IBCHGED)
+ ;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP0.m

-              r628
+              r636
 IBCEP0 ;ALB/TMP - Functions for PROVIDER ID MAINTENANCE ;13-DEC-99
  ;;2.0;INTEGRATED BILLING;**137,191,239,232,320,348,349,377**;21-MAR-94;Build 23
+ ;;2.0;INTEGRATED BILLING;**137,191,239,232,320,348,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
  S IBDSP=Y,IBSORT=""
  I IBDSP="A"!(IBDSP="I") F  D  Q:'IBOK!(IBSORT'="")
+ . ;
+ . I IBDSP="A" D
+ .. S DIR("A")="Display only IDs with a specific ID Qualifier?: "
+ .. S DIR("?",1)="Answer Yes to select a specific ID Qualifier by which to display IDs."
+ .. S DIR("?")="Answer No to display all IDs."
+ .. Q
+ . ;
+ . I IBDSP="I" D
+ .. S DIR("A")="Display IDs for a specific Provider?: "
+ .. S DIR("?",1)="Answer Yes to select a specific Provider."
+ .. S DIR("?")="Answer No to display all Providers."
+ .. Q
+ . ;
+ . S DIR("B")="NO",DIR(0)="YA"
+ . N Z
+ . S Z=$S(IBDSP="I":"",1:" ID TYPE")
+ . S DIR("A")="DO YOU WANT TO DISPLAY IDS FOR A SPECIFIC PROVIDER"_Z_"?: ",DIR("B")="NO",DIR(0)="YA"
+ . S DIR("?",1)="IF YOU ANSWER YES TO THIS QUESTION, YOU MAY SELECT A SPECIFIC PROVIDER"_Z,DIR("?")="  TO DISPLAY, OTHERWISE, ALL PROVIDER"_Z_"S FOUND WILL BE DISPLAYED"
  . W ! D ^DIR K DIR W !
  . I $D(DTOUT)!$D(DUOUT) S IBOK=0 Q
 …
  . ;
  . I IBDSP="A" D  Q
+ .. S DIC(0)="AEMQ",DIC="^IBE(355.97,",DIC("S")="I $S('$P(^(0),U,2):1,1:$P(^(0),U,2)=3)"
+ .. S DIC("A")="Select type of ID Qualifier: "
+ .. D ^DIC K DIC
+ .. S DIC(0)="AEMQ",DIC="^IBE(355.97,",DIC("S")="I $S('$P(^(0),U,2):1,1:$P(^(0),U,2)=3)" D ^DIC K DIC
  .. I Y>0 S IBSORT=+Y Q
  .. I $D(DTOUT)!$D(DUOUT) S IBOK=0

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP0A.m

-              r628
+              r636
 IBCEP0A ;ALB/TMP - EDI UTILITIES for insurance assigned provider ID ;01-NOV-00
+ ;;2.0;INTEGRATED BILLING;**137,232,320,377**;21-MAR-94;Build 23
+ ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**137,232,320**;21-MAR-94
+ ;
 NEW(IBINS,IBPRV,IBPTYP,IBDEF) ; Add new insurance co assigned id
 …
  I '$G(IBPTYP) D  G:IBQ NEWQ
  . S DIR(0)="PAr^355.97:AEMQ",DIR("A")="Select Provider ID Qualifier: "
  . S DIR("?")="Enter a Qualifier to identify the type of ID number you are entering."
+ . S DIR("?")="Enter a Qualifier to indentify the type of ID number you are entering."
  . S DIR("S")="I $$RAINS^IBCEPU(Y)"   ; Rendering/Attending IDs provided by ins
  . S DA=0
 …
+ Q
+ ;
 PRVTJMP(VALMBG) ; Navigate to a specific type of ID qualifier (from ins co option)
+PRVTJMP(VALMBG) ; Navigate to a specific provider id type (from ins co option)
+ ;
  N DIR,X,Y
  D FULL^VALM1
+ S DIR(0)="PAO^355.97:AEMQ",DIR("A")="Select type of ID Qualifier: "
+ S DIR("?")="Select a type of ID Qualifier to display the IDs of that type."
+ S DIR(0)="PAO^355.97:AEMQ",DIR("A")="SELECT PROVIDER ID TYPE: ",DIR("?",1)="SELECTING A PROVIDER ID TYPE WILL FORCE THE DISPLAY TO SKIP TO THE DATA FOR ",DIR("?")="  THAT PROVIDER ID TYPE"
  S DIR("S")="I $D(^TMP(""IBPRV_INS_ID"",$J,""ZXPTYP"",+Y))"
  W ! D ^DIR K DIR W !
 …
  . S Z=$G(^TMP("IBPRV_INS_ID",$J,"ZXPTYP",+Y))
  . I Z S VALMBG=Z Q
  . S DIR(0)="EA",DIR("A",1)="This type of ID Qualifier does not exist in the current display",DIR("A")="Press the Enter key to continue"
+ . S DIR(0)="EA",DIR("A",1)="THIS PROVIDER ID TYPE DOES NOT EXIST IN THE CURRENT DISPLAY",DIR("A")="PRESS THE ENTER KEY TO CONTINUE"
  . W ! D ^DIR K DIR W !
+ Q

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP4.m

-              r628
+              r636
 IBCEP4 ;ALB/TMP - EDI UTILITIES for provider ID ;29-SEP-00
  ;;2.0;INTEGRATED BILLING;**137,320,348,349,377**;21-MAR-94;Build 23
+ ;;2.0;INTEGRATED BILLING;**137,320,348,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
 EN1(IBINS) ; -- Entry point from provider number maintenence
  N IBPRV,IBALL,IB95
- S VALMBCK="R"
  D ENX
+ Q
 …
  K IBFASTXT
  D FULL^VALM1
  S DIR(0)="SA^1:Performing Provider Care Units;2:Billing Provider Care Units"
  S DIR("A")="Enter Type of Care Unit: ",DIR("B")=$P($P(DIR(0),":",2),";",1)
+ S DIR(0)="SA^1:Care Units for Performing Provider IDs;2:Care Units for Billing Provider Secondary IDs"
+ S DIR("A")="Enter Type of Care Unit: ",DIR("B")=$P($P(DIR(0),":",2),";")
  W ! D ^DIR K DIR W !
  I Y'>0 Q
 …
  .. D SET^VALM10(IBLCT,IBQ,IBENT)
+ ;
  I 'IBLCT D SET^VALM10(1,"No CARE UNITs Found"_$S('$G(IBINS):"",1:" for Insurance Co")) S IBLCT=1
+ I 'IBLCT D SET^VALM10(1,"No CARE UNITs Found"_$S('$G(IBINS):"",1:" for Insurance Co"))
  S VALMCNT=IBLCT,VALMBG=1
+ Q
 …
+ ;
 EXIT ; -- exit
+ K IBFASTXT
  D CLEAN^VALM10
  K ^TMP("IBPRV_CU",$J),IBINS,IBALL

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP4A.m

-              r628
+              r636
 IBCEP4A ;ALB/TMP - EDI UTILITIES for provider ID ;29-SEP-00
  ;;2.0;INTEGRATED BILLING;**137,232,280,349,377**;21-MAR-94;Build 23
+ ;;2.0;INTEGRATED BILLING;**137,232,280,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
  ; IB = 0 or null if called from list manager, 1 if not
  N DIC,DIK,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,IB95,IBOK,IBZ,IB0,IBEDIT,IBCK,IBDA,IBCHG,IBDELETE,Z100,DTOUT,DUOUT
  I '$G(IB) D FULL^VALM1 S Y=$$SEL()
  I $G(IB) S DIC("A")="CARE UNIT NAME: ",DIC(0)="AEMQ",DIC("S")="I $P(^(0),U,3)=+$G(IBINS)",DIC="^IBA(355.95," W ! D ^DIC K DIC
+ I '$G(IB) D FULL^VALM1
+ S DIC("A")="CARE UNIT NAME: ",DIC(0)="AEMQ",DIC("S")="I $P(^(0),U,3)=+$G(IBINS)",DIC="^IBA(355.95," W ! D ^DIC K DIC
  I Y'>0 G CHGQ
  S IB95("IBCU")=+Y,IBDELETE=0,IBDELETE(0)=$G(^IBA(355.95,0)),IBDELETE(1)=$G(^(1))
 …
  W ! S DIR("A")="CARE UNIT NAME: ",DIR("B")=$P($G(^IBA(355.95,+IB95("IBCU"),0)),U),DIR(0)="355.95,.01AO",DIR("S")="I $P(^(0),U,3)=IBINS" D ^DIR K DIR
  I $D(DTOUT)!$D(DUOUT) G CHGQ
+ I X="@" S DIR(0)="EA",DIR("A")="NOTHING DELETED - PRESS ENTER TO CONTINUE" D ^DIR K DIR G CHGQ
+ ;
+ ; Care unit name was deleted
+ I X="@" D  G CHGQ
+ . S DIR("A",1)="THIS WILL DELETE THE CARE UNIT NAME AND ALL ITS COMBINATIONS",DIR("A")="ARE YOU SURE THIS IS WHAT YOU WANT TO DO?: ",DIR(0)="YA",DIR("B")="NO" D ^DIR K DIR
+ . I Y'=1 S IB95("IBCU")="" Q  ; Changed their mind - don't delete
+ . S Z=0 F  S Z=$O(^IBA(355.96,"B",IB95("IBCU"),Z)) Q:'Z  S DIK="^IBA(355.96,",DA=Z D ^DIK
+ . S DA=IB95("IBCU"),DIK="^IBA(355.95," D ^DIK
+ . W ! S DIR(0)="EA",DIR("A",1)="CARE UNIT AND ALL ITS COMBINATIONS WERE DELETED",DIR("A")="PRESS ENTER TO CONTINUE " D ^DIR K DIR D BLD^IBCEP4
+ ;
  I $P($G(^IBA(355.95,IB95("IBCU"),0)),U)'=Y S DIE="^IBA(355.95,",DR=".01///"_Y,DA=IB95("IBCU") D ^DIE ; File the name change
  S DR=".02",DIE="^IBA(355.95,",DA=IB95("IBCU") D ^DIE
 …
  Q Y
+ ;
-DELETE(IB) ; delete a care unit name
- ; IB = 0 or null if called from list manager, 1 if not
- N DIR,X,Y
- I '$G(IB) D FULL^VALM1 S Y=$$SEL() I Y'>0 G DELETEQ
- S:'$G(IB) IB95("IBCU")=+Y
- S DIR("A",1)="THIS WILL DELETE THE CARE UNIT NAME AND ALL ITS COMBINATIONS",DIR("A")="ARE YOU SURE THIS IS WHAT YOU WANT TO DO?: ",DIR(0)="YA",DIR("B")="NO" D ^DIR K DIR
- I Y'=1 S IB95("IBCU")="" Q  ; Changed their mind - don't delete
- S Z=0 F  S Z=$O(^IBA(355.96,"B",IB95("IBCU"),Z)) Q:'Z  S DIK="^IBA(355.96,",DA=Z D ^DIK
- S DA=IB95("IBCU"),DIK="^IBA(355.95," D ^DIK
- W ! S DIR(0)="EA",DIR("A",1)="CARE UNIT AND ALL ITS COMBINATIONS WERE DELETED",DIR("A")="PRESS ENTER TO CONTINUE " D ^DIR K DIR D BLD^IBCEP4
-DELETEQ ;
- S:'$G(IB) VALMBCK="R"
+ Q
+ ;
-SEL() ; Select entry from list
- ; returns ien in file 355.95 for selected entry
- N VALMY,SEL
- D EN^VALM2($G(XQORNOD(0)),"S")
- S SEL=+$O(VALMY(""))
- I SEL'>0 Q 0
- Q +$G(^TMP("IBPRV_CU",$J,"ZIDX",SEL))
+ ;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP5.m

-              r628
+              r636
 IBCEP5 ;ALB/TMP - EDI UTILITIES for provider ID ;29-SEP-00
  ;;2.0;INTEGRATED BILLING;**137,232,320,348,349,377**;21-MAR-94;Build 23
+ ;;2.0;INTEGRATED BILLING;**137,232,320,348,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
+ ;
 EXIT ; -- exit code
+ K IBFASTXT
  D COPYPROV^IBCEP5A(IBINS)
  K IBPRV

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP6.m

-              r628
+              r636
 IBCEP6 ;ALB/TMP - PROVIDER ID MAINT menu and INS CO EDIT hook ;11-02-00
+ ;;2.0;INTEGRATED BILLING;**137,232,320,377**;21-MAR-94;Build 23
+ ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**137,232,320**;21-MAR-94
+ ;
+EN ; -- main entry point
+ N IBRESP
+EN ; -- main entry point for IBCE PRV INS PARAMS
  D FULL^VALM1
+ F  Q:'$$MENU(.IBRESP)  D @IBRESP
+ENQ ;
+ D EN^VALM("IBCE PRVMAINT")
+ENQ Q
+ ;
+HDR ; -- header code
+ K VALMHDR
+ Q
+ ;
+INIT ; Initialization
+ N IBLCT,IBCT,Z,Z0
+ S (IBLCT,IBCT)=0,XQORM("B")="Select"
+ K ^TMP("IBCE_PRVMAINT_MENU",$J)
+ F Z=1:1:2 S Z0=$J("",10) D SET1(.IBLCT,Z0,1)
+ S Z0=$J("",17)_"-- PROVIDER ID EDITS --" D SET1(.IBLCT,Z0,1),CNTRL^VALM10(IBLCT,18,23,IORVON,IORVOFF)
+ S Z0=$J("",10)_"1 > PROVIDER SPECIFIC IDS" D SET1(.IBLCT,Z0,1)
+ S Z0=$J("",14)_"o PROVIDER'S OWN IDS" D SET1(.IBLCT,Z0,1)
+ S Z0=$J("",14)_"o PROVIDER IDS FURNISHED BY INSURANCE CO" D SET1(.IBLCT,Z0,1)
+ S Z0=$J("",10)_"2 > INSURANCE CO IDS" D SET1(.IBLCT,Z0,2)
+ ;S Z0=$J("",10)_"3 > FACILITY IDS" D SET1(.IBLCT,Z0,3)  ;WCJ removed
+ S Z0=$J("",10)_"4 > CARE UNIT MAINTENANCE" D SET1(.IBLCT,Z0,4)
+ S Z0=$J("",14)_"o Care Units for Performing Provider IDs" D SET1(.IBLCT,Z0,1)
+ S Z0=$J("",14)_"o Care Units for Billing Provider Secondary IDs" D SET1(.IBLCT,Z0,1)
+ S Z0=$J("",10)_"5 > INS CO BATCH ID ENTRY" D SET1(.IBLCT,Z0,5)
+ F Z=1:1:2 S Z0=$J("",10) D SET1(.IBLCT,Z0,6)
+ S Z0=$J("",14)_"-- NON/OTHER VA ENTITY EDITS --" D SET1(.IBLCT,Z0,6),CNTRL^VALM10(IBLCT,15,31,IORVON,IORVOFF)
+ S Z0=$J("",10)_"6 > NON/OTHER VA PROVIDER ID INFORMATION" D SET1(.IBLCT,Z0,6)
+ K VALMBG,VALMCNT
+ S VALMBG=1,VALMCNT=IBLCT
+ Q
+ ;
+SET1(IBLCT,Z0,IBCT) ;
+ S IBLCT=IBLCT+1 D SET^VALM10(IBLCT,Z0,$G(IBCT))
+ Q
+ ;
+EXPND ;
+ Q
+ ;
+HELP ;
+ Q
+ ;
+EXIT ;
+ K ^TMP("IBCE_PRVMAINT_MENU",$J)
+ D CLEAN^VALM10
+ Q
+ ;
+SEL ;
+ N Z,Z1,DIR
+ D FULL^VALM1
+ D EN^VALM2($G(XQORNOD(0)),"OS")
+ S Z=+$O(VALMY(0))
+ I Z,Z<6,'$D(^XUSEC("IB PROVIDER EDIT",DUZ)) S DIR(0)="EA",DIR("A",1)="YOU ARE NOT AUTHORIZED TO EDIT PROVIDER IDS",DIR("A")="Press ENTER to continue" W ! D ^DIR K DIR W ! G SELQ
+ I Z=3 D  G SELQ
+ . S DIR(0)="EA",DIR("A",1)="This Action is no longer available",DIR("A")="Press ENTER to continue"
+ . D ^DIR K DIR
+ I Z S Z1=$P($T(ACT+Z),U,2,3) I Z1'="" D @Z1
+SELQ K VALMBCK,XQORM("B")
+ S VALMBCK="R",XQORM("B")="Quit"
+ Q
+ ;
 EN1 ; Provider maintenance from the billing screen 8
  N DIR,X,Y,IBEDIT
+ ;S IBEDIT=1
  W !
+ ;S DIR(0)="YA",DIR("B")="NO",DIR("A",1)="WANT TO ATTEMPT TO RESET ALL PROVIDER IDS TO THE CALCULATED",DIR("A")="DEFAULTS FOR THIS BILL?: " D ^DIR K DIR
+ ;Q:$D(DTOUT)!$D(DUOUT)
+ ;I Y=1 S IBEDIT=0 D RECALCA^IBCEP2A(IBIFN) W !
+ ;
  I '$D(^XUSEC("IB PROVIDER EDIT",DUZ)) S DIR(0)="EA",DIR("A")="Press ENTER to continue: ",DIR("A",1)="YOU LACK THE SECURITY KEY FOR THIS ACTION" D ^DIR K DIR Q
+ ;I 'IBEDIT D
+ ;. S DIR(0)="YA",DIR("A")="WANT TO CONTINUE WITH GENERAL PROVIDER ID MAINTENANCE?: ",DIR("B")="NO" D ^DIR K DIR
+ ;. I $D(DTOUT)!$D(DUOUT)!'Y Q
+ ;. S IBEDIT=1
  D EN
+ Q
+ ;
+PO ; provider's own IDs
+ N IBPRV,IBINS
+ N IBSLEV,DIR,Y,X,IBPRMPT,IBNVAFL,IBIF
+ K IBFASTXT
+ S IBIF=""
+ S IBPRMPT="PROVIDER"
+ D FULL^VALM1
+ S IBSLEV=1
+ D EN^VALM("IBCE PRVPRV MAINT")
+POX ;
+ Q
+ACT ; Actions available
+ ;;PROVIDER LEVEL ID EDIT^EN^IBCEP5
+ ;;INS CO LEVEL ID EDIT^EN^IBCEP0
+ ;;
+ ;;CARE UNIT EDIT^EN^IBCEP4
+ ;;BATCH ID ENTRY BY INS CO^EN^IBCEP9
+ ;;NON-VA PROVIDER EDIT^EN^IBCEP8
+ ;
-PI ; provider's IDs provided by an insurance company
- N IBPRV,IBINS
- N IBSLEV,DIR,Y,X,IBPRMPT,IBNVAFL,IBIF
- K IBFASTXT
- S IBIF=""
- S IBPRMPT="PROVIDER"
- D FULL^VALM1
- S IBSLEV=2
- D EN^VALM("IBCE PRVPRV MAINT")
-PIX ;
+ Q
+ ;
-BI ; Insurance company batch ID entry
- D EN^IBCEP9
-BIX ;
+ Q
+ ;
+II ; Insurance company IDs
+ D EN^IBCEP0
+IIX ;
+ Q
+ ;
+CP ; Care Unit maintenance - performing providers
+ N IBINS,IBALL,IB95
+ N IBSLEV,DIR,Y
+ K IBFASTXT
+ D FULL^VALM1
+ S IBSLEV=1
+ D EN^VALM("IBCE PRVCARE UNIT MAINT")
+CPX ;
+ Q
+ ;
+CB ; Care Unit maintenance - billing provider
+ N IBINS,IBALL,IB95
+ N IBSLEV,DIR,Y
+ K IBFASTXT
+ D FULL^VALM1
+ S IBSLEV=2
+ D EN^VALM("IBCE 2ND PRVID CARE UNIT MAINT")
+CBX ;
+ Q
+ ;
+NP ; non-VA individual provider information
+ N IBNVPMIF
+ S IBNVPMIF="I"
+ D EN^IBCEP8
+NPX ;
+ Q
+ ;
+NF ; non-VA facility provider information
+ N IBNVPMIF
+ S IBNVPMIF="F"
+ D EN^IBCEP8
+NFX ;
+ Q
+ ;
+MENU(IBSEL) ; display main provider ID maintenance menu and receive response from user
+ ; function value returns 0 if user exits from menu or "^" out
+ ; function value returns 1 otherwise
+ ; IBSEL is the internal value of the user's selection if any (pass by reference)
+ N IBQ,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,C,Z
+ N IORESET,IORVON,IORVOFF,IOUON,IOUOFF,IOINHI,IOINLOW,IOINORM
+ S IBQ=1,IBSEL=""
+ S X="IORESET;IORVON;IORVOFF;IOUON;IOUOFF;IOINHI;IOINLOW;IOINORM"
+ D ENDR^%ZISS
+ ;
+ S $P(DIR(0),U,1)="SOA"
+ S $P(Z,";",1)="PO:Provider Own IDs"
+ S $P(Z,";",2)="PI:Provider Insurance IDs"
+ S $P(Z,";",3)="BI:Batch ID Entry"
+ S $P(Z,";",4)="II:Insurance Co IDs"
+ S $P(Z,";",5)="CP:Care Units for Providers"
+ S $P(Z,";",6)="CB:Care Units for Billing Provider"
+ S $P(Z,";",7)="NP:Non-VA Provider"
+ S $P(Z,";",8)="NF:Non-VA Facility"
+ ;
+ S $P(DIR(0),U,2)=Z
+ ;
+ S DIR("L",1)="                "_IOINHI_"Provider IDs"_IOINORM
+ S DIR("L",2)="          "_$P($P(Z,";",1),":",1)_"  "_$P($P(Z,";",1),":",2)
+ S DIR("L",3)="          "_$P($P(Z,";",2),":",1)_"  "_$P($P(Z,";",2),":",2)
+ S DIR("L",4)=""
+ S DIR("L",5)="                "_IOINHI_"Insurance IDs"_IOINORM
+ S DIR("L",6)="          "_$P($P(Z,";",3),":",1)_"  "_$P($P(Z,";",3),":",2)
+ S DIR("L",7)="          "_$P($P(Z,";",4),":",1)_"  "_$P($P(Z,";",4),":",2)
+ S DIR("L",8)=""
+ S DIR("L",9)="                "_IOINHI_"Care Units"_IOINORM
+ S DIR("L",10)="          "_$P($P(Z,";",5),":",1)_"  "_$P($P(Z,";",5),":",2)
+ S DIR("L",11)="          "_$P($P(Z,";",6),":",1)_"  "_$P($P(Z,";",6),":",2)
+ S DIR("L",12)=""
+ S DIR("L",13)="                "_IOINHI_"Non-VA Items"_IOINORM
+ S DIR("L",14)="          "_$P($P(Z,";",7),":",1)_"  "_$P($P(Z,";",7),":",2)
+ S DIR("L")="          "_$P($P(Z,";",8),":",1)_"  "_$P($P(Z,";",8),":",2)
+ ;
+ S DIR("?")="^D MENH^IBCEP6"
+ S DIR("A")="    Select Provider ID Maintenance Option: "
+ ;
+ ; paint the screen and display menu first time in
+ D MENH
+ W !
+ S C=0 F  S C=$O(DIR("L",C)) Q:'C  W !,DIR("L",C)
+ W !,DIR("L"),!
+ D ^DIR K DIR W !
+ I $D(DIRUT) S IBQ=0 G MENUX
+ S IBSEL=Y
+ I IBSEL="" S IBQ=0
+MENUX ;
+ Q IBQ
+ ;
+MENH ; menu help
+ W @IOF,!?4,"Provider ID Maintenance Main Menu"
+ W !!?4,"Enter a code from the list."
+MENHX ;
+ Q
+ ;
+ ;;SITE LEVEL ID EDIT^EN^IBCEP7

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP8.m

-              r628
+              r636
 IBCEP8 ;ALB/TMP - Functions for NON-VA PROVIDER ;11-07-00
+ ;;2.0;INTEGRATED BILLING;**51,137,232,288,320,343,374,377**;21-MAR-94;Build 23
+ ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**51,137,232,288,320,343,374**;21-MAR-94;Build 16
+ ;
 EN ; -- main entry point
 …
  N DIC,DA,X,Y,DLAYGO,IBIF,DIR,DTOUT,DUOUT
  K ^TMP("IBCE_PRVNVA_MAINT",$J)
+ ;
- ; if coming in from main routine ^IBCEP6 this special variable IBNVPMIF is set already
- I $G(IBNVPMIF)'="" S IBIF=IBNVPMIF G INIT1
+ ;
  S DIR("A")="(I)NDIVIDUAL OR (F)ACILITY?: ",DIR(0)="SA^I:INDIVIDUAL;F:FACILITY" D ^DIR K DIR
  I $D(DUOUT)!$D(DTOUT) S VALMQUIT=1 G INITQ
  S IBIF=Y
+ ;
-INIT1 ;
+ ;
  I IBIF="F" D
 …
  . I Y S VALM("PROTOCOL")=+Y_";ORD(101,"
+ ;
  S DIC="^IBA(355.93,",DIC("DR")=".02///"_$S(IBIF'="F":2,1:1)
+ S DIC="^IBA(355.93,",DIC("DR")=".02////"_$S(IBIF'="F":2,1:1)
  S DIC("S")="I $P(^(0),U,2)="_$S(IBIF'="F":2,1:1)
  S DLAYGO=355.93,DIC(0)="AELMQ",DIC("A")="Select a NON"_$S(IBIF="I":"-",1:"/OTHER ")_"VA PROVIDER: "
 …
+ Q
+ ;
+EDITID(IBNPRV,IBSLEV) ; Link from this list template to maintain provider-specific ids
+ ; This entry point is called by 4 action protocols.
+ ; IBNPRV = ien of entry in file 355.93 (can be either an individual or a facility) (required)
+ ; IBSLEV = 1 for facility/provider own ID's
+ ; IBSLEV = 2 for facility/provider ID's furnished by an insurance company
+ ;
+ Q:'$G(IBNPRV)
+ Q:'$G(IBSLEV)
+ N IBPRV,IBIF
+ D FULL^VALM1    ; set full scrolling region
+ D CLEAR^VALM1   ; clear screen
+EDITID(IBNPRV) ; Link from this list template to maintain provider-specific ids
+ ; IBNPRV = ien of entry in file 355.93
+ N IBPRV
+ D FULL^VALM1
+ D CLEAR^VALM1
  S IBPRV=IBNPRV
+ ;
+ K IBFASTXT
+ S IBIF=$$GET1^DIQ(355.93,IBPRV,.02,"I")    ; 1=facility/group      2=individual
+ D EN^VALM("IBCE PRVPRV MAINT")
+ ;
+ D EN1^IBCEP5
  K VALMQUIT
  S VALMBCK=$S($G(IBFASTXT)'="":"Q",1:"R")
+ S VALMBCK="R"
+ Q
+ ;
 NVAFAC ; Enter/edit Non-VA facility information
- ; This entry point is called by the menu system for option IBCE PRVNVA FAC EDIT
  N X,Y,DA,DIC,IBNPRV,DLAYGO
  S DIC="^IBA(355.93,",DIC("S")="I $P(^(0),U,2)=1",DIC("DR")=".02///1"
+ S DIC="^IBA(355.93,",DIC("S")="I $P(^(0),U,2)=1",DIC("DR")=".02////1"
  S DLAYGO=355.93,DIC(0)="AELMQ",DIC("A")="Select a NON/Other VA FACILITY: "
  D ^DIC K DIC,DLAYGO

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP82.m

-              r628
+              r636
 IBCEP82 ;ALB/CLT, Special cross references and data entry for fields in file 355.93 ; 14 Apr 2006  9:41 AM
+ ;;2.0;INTEGRATED BILLING;**343,374,377**;21-MAR-94;Build 23
+ ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**343,374**;21-MAR-94;Build 16
+ ;
  ; Call at tags only
 …
  I X="@" G:IBOLDNPI'="" DEL W *7,"??" G EN1
  I $G(DUOUT)!$G(DTOUT)!(X="")!(Y=IBOLDNPI) G XIT
+ I '$$PROC(Y,IBOLDNPI,IBIEN) G EN1
+ G XIT
+ ;
+EN2(DA,INDENT) ; entry point from input templates IB SCREEN82 and IB SCREEN8H
+ N DTOUT,DUOUT,DIR,DIE,DIC,DR,X,Y
+ N IBIEN,IBNPI,IBCHECK,IBOLDNPI,IBRBNPI,IBRB,SPACES
+ S IBIEN=DA,IBOLDNPI="",SPACES="          "
+EN21 ;
+ K DIR
+ S DIR(0)="FO^10:10",DIR("A")=$E(SPACES,1,INDENT)_"NPI",DIR("?")=$E(SPACES,1,INDENT)_"Enter a 10 digit National Provider Identifier"
+ I $G(DA) S:$P($G(^IBA(355.93,DA,0)),U,14)'="" (DIR("B"),IBOLDNPI)=$P($G(^IBA(355.93,DA,0)),U,14)
+ D ^DIR S IBCHECK=0
+ I X="@" G:IBOLDNPI'="" DEL W *7,"??" G EN21
+ I $G(DUOUT)!$G(DTOUT)!(X="")!(Y=IBOLDNPI) G XIT
+ I '$$PROC(Y,IBOLDNPI,IBIEN) G EN21
+ G XIT
+ ;
+PROC(IBNPI,IBOLDNPI,IBIEN) ; process new NPI
+ I '$$CHKDGT^XUSNPI(IBNPI) W !,*7,$E($G(SPACES),1,+$G(INDENT))_"Not a valid NPI.  Please try again.",! Q 0
+ I $$NPIUSED^IBCEP81(IBNPI) Q 0
+ S IBNPI=Y
+ I '$$CHKDGT^XUSNPI(IBNPI) W !,*7,"Not a valid NPI.  Please try again.",! G EN1
+ I $$NPIUSED^IBCEP81(IBNPI) G EN1
  S IBCHECK=1
  I IBOLDNPI="" D ACTI
  I IBOLDNPI'="" D:IBNPI'=IBOLDNPI INACT
  S $P(^IBA(355.93,IBIEN,0),U,14)=IBNPI,^IBA(355.93,"NPI",IBNPI,IBIEN)="",^IBA(355.93,"NPIHISTORY",IBNPI,IBIEN)=""
  Q 1
+ G XIT
+ ;
 ACTI ;CREATE AN ACTIVATED ENTRY IN MULTIPLE NPISTATUS FIELD

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEPA.m

-              r628
+              r636
 IBCEPA ;ALB/WCJ - Provider ID functions - Care Units ;21-OCT-2005
+ ;;2.0;INTEGRATED BILLING;**320,348,377**;21-MAR-94;Build 23
+ ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+ ;;2.0;INTEGRATED BILLING;**320,348**;21-MAR-94;Build 5
 EN ; -- main entry point for IBCE 2ND PRVID CARE UNIT MAINT
  D EN^VALM("IBCE 2ND PRVID CARE UNIT MAINT")
 …
  D CLEAN^VALM10
  K ^TMP("IBPRV_CU",$J)
  N TAR,MSG,I,D0,IBCT,Z,DIV,SCREEN
+ N TAR,MSG,I,D0,IBLCT,Z,DIV,SCREEN
+ ;
  S VALMBG=1
 …
  ... S IN=^TMP("IBPRV_CU",$J,"SORT",DIV,D0)
  ... S Z=$J("",2)
  ... S Z=Z_$E(IN_"    ",1,4)_$E(TAR("DILIST","ID",IN,.01),1,36)
+ ... S Z=Z_$E(TAR("DILIST","ID",IN,.01),1,36)
  ... S Z=Z_$J("",40-$L(Z))
  ... S Z=Z_$E(TAR("DILIST","ID",IN,.02),1,38)
  ... S IBCT=IBCT+1
  ... D SET^VALM10(IBCT,Z)
+ ;
- ; correct the VALMCNT variable - number of lines in the list (not entries)
- S VALMCNT=+$O(@VALMAR@(""),-1)
+ Q
+ ;
 …
 EXIT ; -- exit code
  D CLEAN^VALM10
- K ^TMP("IBPRV_CU",$J)
+ Q
+ ;
 …
  ; Assumes IBINS is defined as ins co ien (file 36)
  ; IB = 0 or null if called from list manager, 1 if not
  N DIC,DIR,X,Y,Z,D,DA,DR,DIE,DO,DD,DLAYGO,IB95,IBADD,IBOK,IBDIV,MAIN,IBDIVNM
+ N DIC,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,IB95,IBADD,IBOK,IBDIV,MAIN,IBDIVNM
+ ;
  D FULL^VALM1
 …
  S MAIN=$$EXTERNAL^DILFD(355.92,.05,"",MAIN)
  S DIC=40.8,DIC("A")="Enter the Division for this Care Unit: ",DIC("B")=MAIN,DIC(0)="AEMQ"
+ S D="B^C"
+ D MIX^DIC1
+ D ^DIC
  I Y'>0 G NEWQ
  S IBDIV=+Y
 …
 CHANGE ; Edit care unit
  ; Assumes IBINS is defined as ins co ien (file 36)
+ ;
+ ;
  D FULL^VALM1
+ ;
  N X,Y,Z,D,DA,DD,DIC,DIK,DIR,IBDIV,CAREUNIT,SCREEN,TAR,DIVISION,I
+ N X,Y,Z,DA,DD,DIC,DIK,DIR,IBDIV,CAREUNIT,SCREEN,TAR,DIVISION
+ ;
  S SCREEN="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)]"""""
 …
  S DIC(0)="AEMQ"
  S DIC("S")="I $D(DIVISION($P(^(0),U)))"
+ S D="B^C"
+ D MIX^DIC1
+ D ^DIC
  I Y'>0 G CHANGEQ
  S IBDIV=+Y
+ S DA=$$SEL($P(Y,U,2)) I 'DA G CHANGEQ
+ S DIE=355.95
+ ;
+ S DIC("A")="Enter the Care Unit name: "
+ S DIC=355.95,DIC("S")="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)",DIC(0)="AEMQ"
+ D ^DIC
+ I Y<1 G CHANGEQ
+ ;
+ S DA=+Y,DIE=355.95
  S DR=".01Care Unit;.04Division;.02Description"
  D ^DIE
 …
+ ;
  D FULL^VALM1
  N X,Y,Z,D,DA,DD,DIC,DIK,DIR,IBDIV,CAREUNIT,SCREEN,TAR,DIVISION
+ N X,Y,Z,DA,DD,DIC,DIK,DIR,IBDIV,CAREUNIT,SCREEN,TAR,DIVISION
+ ;
  S SCREEN="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)]"""""
 …
  S DIC(0)="AEMQ"
  S DIC("S")="I $D(DIVISION($P(^(0),U)))"
+ S D="B^C"
+ D MIX^DIC1
+ D ^DIC
  I Y'>0 G DELQ
  S IBDIV=+Y
+ S CAREUNIT=$$SEL($P(Y,U,2)) I 'CAREUNIT G DELQ
+ ;
+ K DIC
+ S DIC("A")="Enter the Care Unit name: "
+ S DIC=355.95,DIC("S")="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)",DIC(0)="AEMQ"
+ D ^DIC
+ I Y<1 G DELQ
+ S CAREUNIT=+Y
+ ;
  I $D(^IBA(355.92,"AC",+Y)) D  G DELQ
 …
+ Q
+ ;
-SEL(DIV) ; select care unit for a given division
- ; DIV - name of division
- ; returns ien of selected care unit, or 0 if nothing is selected
- N DIR,I,IEN,MIN,MAX,X,Y
- I $G(DIV)="" Q 0
- S IEN=0
- S I=$O(^TMP("IBPRV_CU",$J,"SORT",DIV,"")),MIN=$G(^TMP("IBPRV_CU",$J,"SORT",DIV,I))
- S I=$O(^TMP("IBPRV_CU",$J,"SORT",DIV,""),-1),MAX=$G(^TMP("IBPRV_CU",$J,"SORT",DIV,I))
- I MIN=MAX S IEN=I
- I MIN'=MAX D
- .S DIR("A")="Select CARE UNITS",DIR(0)="N^"_MIN_":"_MAX_":0" D ^DIR
- .Q:$D(DTOUT)!$D(DUOUT)
- .S I="" F  S I=$O(^TMP("IBPRV_CU",$J,"SORT",DIV,I)) Q:I=""!(IEN>0)  S:$G(^TMP("IBPRV_CU",$J,"SORT",DIV,I))=Y IEN=I
- .Q
- Q IEN

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCERP3.m

-              r628
+              r636
 IBCERP3 ;ALB/TMP - EDI BATCHES WAITING MORE THAN 1 DAY REPORT ;30-SEP-96
+ ;;2.0;INTEGRATED BILLING;**137,296,377**;21-MAR-94;Build 23
+ ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+ ;;2.0;INTEGRATED BILLING;**137,296**;21-MAR-94
+ Q
+ ;
+PENDING ; Report of batches not sent after the day the bills in it were extracted - report entry point
+ ;
+ NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,IBCLM
+ I '$O(^IBA(364.1,"ASTAT","P",0)) W !!,"There are no batches that are Pending Austin Receipt.",! S DIR(0)="E" D ^DIR K DIR G EX
+ ;
+ ; Ask user if they want to include claim level detail
+ S DIR(0)="Y",DIR("A")="Include Claims in each Batch",DIR("B")="Yes"
+ W ! D ^DIR K DIR
+ I $D(DIRUT) G EX
+ S IBCLM=+Y
+ ;
+ D DEVICE
+EX ;
+ Q
+ ;
+DEVICE ; selection of device on which to print report
+ NEW ZTRTN,ZTDESC,ZTSAVE,POP
+ W !!,"This report is 80 characters wide."
+ S ZTRTN="COMPILE^IBCERP3"
+ S ZTDESC="REPORT OF BILL BATCHES WAITING AUSTIN RECEIPT AFTER 1 DAY"
+ S ZTSAVE("IBCLM")=""
+ D EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE,"QM")
+DEVICEX ;
+ Q
+ ;
+COMPILE ; Queued job entrypoint
+ N IBBA,IB0,IB1,IEN,IBZ,IBIFN,IB399,CLM,BALDUE,IBSTAT,ARSTAT,IB
+PENDING ;Report of batches not sent after the day the bills in it were extracted
+ W !
+ S %ZIS="QM" D ^%ZIS Q:POP
+ I $D(IO("Q")) K IO("Q") S ZTRTN="EN^IBCERP3",ZTDESC="REPORT OF BILL BATCHES WAITING AUSTIN RECEIPT AFTER 1 DAY" D ^%ZTLOAD K ZTSK D HOME^%ZIS Q
+ U IO
+EN ; Queued job entrypoint
+ N IBPAGE,IBHDRDT,IBLINE,IBSTOP,IBBA,IBBAT,IBCT,IBTYP,IBTYPN,IBV,DIR,Y,IB0,IB1
+ ;
  K ^TMP($J,"IBSORT")
+ S IBBA=0
+ F  S IBBA=$O(^IBA(364.1,"ASTAT","P",IBBA)) Q:'IBBA  D
+ . I $$BCHCHK^IBCEBUL(IBBA) Q    ; Batch check function
+ . S IB0=$G(^IBA(364.1,IBBA,0)),IB1=$G(^(1))
+ . S:$P(IB0,U,7)="" $P(IB0,U,7)="~"
+ . S ^TMP($J,"IBSORT",$P(IB0,U,7),$P(IB0,U,1),IBBA)=$P(IB1,U,6)_U_$P(IB0,U,4)
+ . ;
+ . I 'IBCLM Q   ; include claim data flag
+ . ;
+ . ; gather the EDI claim data for this batch
+ . S IEN=0 F  S IEN=$O(^IBA(364,"C",IBBA,IEN)) Q:'IEN  D
+ .. S IBZ=$G(^IBA(364,IEN,0)),IBIFN=+IBZ,IB399=$G(^DGCR(399,IBIFN,0))
+ .. S CLM=$P(IB399,U,1) S:CLM="" CLM="~"
+ .. S BALDUE=$G(^DGCR(399,IBIFN,"U1")),BALDUE=$P(BALDUE,U,1)-$P(BALDUE,U,2)
+ .. S IBSTAT=$$EXTERNAL^DILFD(399,.13,,$P(IB399,U,13))
+ .. S ARSTAT=$$EXTERNAL^DILFD(430,8,,+$P($$BILL^RCJIBFN2(IBIFN),U,2))
+ .. S IB=$P(IBZ,U,8)_U_BALDUE_U_$P(IBZ,U,3)_U_IBSTAT_U_ARSTAT
+ .. S ^TMP($J,"IBSORT",$P(IB0,U,7),$P(IB0,U,1),IBBA,CLM,IEN)=IB
+ .. Q
+ . Q
+ S (IBPAGE,IBBA)=0
+ ;
+ D PRINT                         ; print report
+ D ^%ZISC                        ; close the device
+ K ^TMP($J,"IBSORT")             ; clean up scratch global
+ I $D(ZTQUEUED) S ZTREQ="@"      ; purge the task record
+ ; esg - 5/12/05 - IB*2*296 - Additional check to make sure there are
+ ;       bills in the batch in file 364 before including it.  Similar to
+ ;       existing functionality in routine ^IBCEBUL.
+ ;
+COMPX ;
+ Q
+ F  S IBBA=$O(^IBA(364.1,"ASTAT","P",IBBA)) Q:'IBBA  S IB0=$G(^IBA(364.1,IBBA,0)),IB1=$G(^(1)) I DT-($P(IB1,U,6)\1)'<1,$P(IB0,U,7)'="",$O(^IBA(364,"C",IBBA,0)) S ^TMP($J,"IBSORT",$P(IB0,U,7),$P(IB0,U),IBBA)=$P(IB1,U,6)_U_$P(IB0,U,4)
+ ;
+PRINT ; print the report to the specified device
+ ;
+ NEW CRT,IBPAGE,IBSTOP,IBCT,IBTYP,IBBAT,IBBA,IBV,CLM,IEN,DIR,X,Y,Z
+ I IOST["C-" S CRT=1
+ E  S CRT=0
+ ;
+ S IBPAGE=0
+ I '$D(^TMP($J,"IBSORT")) D HDR1 W !,?3,"No batches found Pending Austin Receipt for >1 day."
+ W:$E(IOST,1,2)["C-" @IOF ;Only initial form feed for print to screen
+ I '$D(^TMP($J,"IBSORT")) D HDR1("") W !,?3,"No data found for this report"
  S (IBSTOP,IBCT)=0
+ ;
  S IBTYP=""
+ F  S IBTYP=$O(^TMP($J,"IBSORT",IBTYP)) Q:IBTYP=""  D  Q:IBSTOP
+ . D HDR1
+ F  S IBTYP=$O(^TMP($J,"IBSORT",IBTYP)) Q:IBTYP=""  D  G:IBSTOP STOP
+ . S IBTYPN=$$EXPAND^IBTRE(364.1,.07,IBTYP)
+ . D HDR1(IBTYPN)
  . S IBBAT=""
+ . F  S IBBAT=$O(^TMP($J,"IBSORT",IBTYP,IBBAT)) Q:'IBBAT!(IBSTOP)  S IBBA=0 F  S IBBA=$O(^TMP($J,"IBSORT",IBTYP,IBBAT,IBBA)) Q:'IBBA!IBSTOP  S IBV=$G(^(IBBA)) D  Q:IBSTOP
+ .. D:$Y>(IOSL-4) HDR1 Q:IBSTOP
+ .. W !,?2,IBBAT,?16,$$FMTE^XLFDT($P(IBV,U,1),"5Z"),?42,$P(IBV,U,2)
+ .. S IBCT=IBCT+1
+ .. I 'IBCLM Q    ; no claim level detail
+ .. I $O(^TMP($J,"IBSORT",IBTYP,IBBAT,IBBA,""))="" Q   ; no claim data
+ .. ;
+ .. D:$Y>(IOSL-4) HDR1 Q:IBSTOP
+ .. W !!?5,"Claim",?14,"Seq",?22,"Bal Due",?32,"EDI Stat",?43,"IB Status",?57,"AR Status"
+ .. S CLM="" F  S CLM=$O(^TMP($J,"IBSORT",IBTYP,IBBAT,IBBA,CLM)) Q:CLM=""!IBSTOP  S IEN=0 F  S IEN=$O(^TMP($J,"IBSORT",IBTYP,IBBAT,IBBA,CLM,IEN)) Q:'IEN!IBSTOP  D  Q:IBSTOP
+ ... S IBV=$G(^TMP($J,"IBSORT",IBTYP,IBBAT,IBBA,CLM,IEN))
+ ... D:$Y>(IOSL-4) HDR1 Q:IBSTOP
+ ... W !,?5,CLM,?15,$P(IBV,U,1),?19,$J($FN($P(IBV,U,2),"",2),10),?35,$P(IBV,U,3),?43,$E($P(IBV,U,4),1,11),?57,$E($P(IBV,U,5),1,16)
+ ... Q
+ .. ;
+ .. Q:IBSTOP
+ .. D:$Y>(IOSL-4) HDR1 Q:IBSTOP
+ .. W !
+ .. Q
+ . Q
+ . F  S IBBAT=$O(^TMP($J,"IBSORT",IBTYP,IBBAT)) Q:'IBBAT!(IBSTOP)  S IBBA=0 F  S IBBA=$O(^TMP($J,"IBSORT",IBTYP,IBBAT,IBBA)) Q:'IBBA  S IBV=$G(^(IBBA)) D  Q:IBSTOP
+ .. D:IBLINE>(IOSL-5) HDR1(IBTYPN) Q:IBSTOP
+ .. W !,?6,IBBAT,?20,$$FMTE^XLFDT($P(IBV,U),1),?46,$P(IBV,U,2)
+ .. S IBCT=IBCT+1,IBLINE=IBLINE+1
+ ;
+ I IBSTOP G PRINTX
+ D:$Y>(IOSL-4) HDR1 G:IBSTOP PRINTX
+ W !!,"Total Number of Batches: ",IBCT
+ D:$Y>(IOSL-4) HDR1 G:IBSTOP PRINTX
+ W !!?5,"*** End of Report ***"
+ I CRT,'$D(ZTQUEUED) S DIR(0)="E" D ^DIR K DIR
+PRINTX ;
+ W !!,"TOTAL # OF BATCHES: ",IBCT
+ ;
+ I $E(IOST,1,2)["C-"  K DIR S DIR(0)="E" D ^DIR K DIR
+STOP I '$D(ZTQUEUED) D ^%ZISC
+ I $D(ZTQUEUED) S ZTREQ="@"
+ K ^TMP($J,"IBSORT")
+ Q
+ ;
+HDR1 ; Report header
+ ;
+ ; if screen output and page# already exists, do a page break
+ I IBPAGE,CRT D  I IBSTOP G HDR1X
+ . S DIR(0)="E" D ^DIR K DIR
+ . I 'Y S IBSTOP=1
+ . Q
+ ;
+ ; if screen output OR page# already exists, do a form feed
+ I IBPAGE!CRT W @IOF
+ ;
+HDR1(IB) ; Report header
+ ; IB = the text for the type of batch
+ N Z,DIR,Y
+ I 'IBPAGE S IBHDRDT=$$HTE^XLFDT($H,2)
+ I IBPAGE D  Q:IBSTOP
+ . I $E(IOST,1,2)["C-" K DIR S DIR(0)="E" D ^DIR K DIR S IBSTOP=('Y) Q:IBSTOP
+ . W @IOF
  S IBPAGE=IBPAGE+1
+ ;
+ W !,"EDI Batches Pending Austin Receipt After 1 Day",?70,"Page: ",IBPAGE
+ W !,"Run Date: ",$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
+ W !!?2,"Batch #",?16,"Transmission Date",?42,"Mail Message #"
+ S Z="",$P(Z,"-",79)="" W !?1,Z
+ ;
+ ; check for a TaskManager stop request
+ I $D(ZTQUEUED),$$S^%ZTLOAD() D  G HDR1X
+ . S (ZTSTOP,IBSTOP)=1
+ . W !!!?5,"*** Report Halted by TaskManager Request ***"
+ . Q
+HDR1X ;
+ W !,?14,"REPORT OF BATCHES STILL WAITING AUSTIN RECEIPT AFTER 1 DAY",?70,"PAGE: ",IBPAGE,!,?((68-$L(IB))\2),"BATCH TYPE: "_IB
+ W !,?26,"RUN DATE: ",IBHDRDT,!
+ W !,?6,"BATCH #",?20,"WAITING SINCE",?46,"MAIL MESSAGE #",!
+ S Z="",$P(Z,"-",76)="" W ?2,Z,!
+ S IBLINE=6
+ Q
+ ;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEST.m

-              r628
+              r636
 IBCEST ;ALB/TMP - 837 EDI STATUS MESSAGE PROCESSING ;17-APR-96
+ ;;2.0;INTEGRATED BILLING;**137,189,197,135,283,320,368**;21-MAR-94;Build 21
+ ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**137,189,197,135,283,320**;21-MAR-94
  ; IA 4042 for call to AUDITX^PRCAUDT
+ Q
 …
  ;       1 = single bill 0 = batch
+ ;
  N DA,DIK,DIE,DIC,X,Y,DR,DO,DD,DLAYGO,Z,Z0,Z1,Z2,Z3,IBT,IBDUP,IBFLDS,IBY,IBAUTO,IBLN
+ N DA,DIK,DIE,DIC,X,Y,DR,DO,DD,DLAYGO,Z,Z0,Z1,IBT,IBDUP,IBFLDS,IBY,IBAUTO
+ ;
  S X=IBBILL,IBDUP=0
 …
  . D BLDMSG(IB1,IBTDA,.IBT,.IBAUTO)
  . ;
+ . ; IB*2*368 - ymg - 2Q,RE,RP messages will be filed as informational
+ . ; Z0 is the flag for 2Q code
+ . ; Z1 is the flag for RE code
+ . ; Z2 is the flag for RP code
+ . ; Z3 is the flag for autofiling the message
+ . I $P($G(^IBM(361,+IBY,0)),U,3)="R" D
+ .. S Z="",(Z0,Z1,Z2,Z3)=0 F  S Z=$O(IBT(Z)) Q:Z=""!(Z3=1)  D
+ ... S IBLN=$$UP^XLFSTR($G(IBT(Z)))
+ ... I (Z0!Z1!Z2)=0 D
+ .... S:IBLN?.E1"CODE:".P1"2Q".E Z0=1
+ .... S:IBLN?.E1"CODE:".P1"RE".E Z1=1
+ .... S:IBLN?.E1"CODE:".P1"RP".E Z2=1
+ ... I Z0=1 S:IBLN?.P1"CLAIM".P1"REJECTED".P1"BY".P1"CLEARINGHOUSE".E Z3=1
+ ... I Z1=1 S:IBLN?.P1"ELECTRONIC".P1"CLAIM".P1"REJECTED".P1"BY".P1"EMDEON".E Z3=1
+ ... I Z2=1 S:IBLN?.P1"PAPER".P1"CLAIM".P1"REJECTED".P1"BY".P1"EMDEON".E Z3=1
+ .. I Z3=1 S IBAUTO=1,DIE=361,DA=+IBY,DR=".03////I" D ^DIE
+ . ; IB*2*320 - esg - 2Q messages will be filed as informational
+ . I $P($G(^IBM(361,+IBY,0)),U,3)="R",$G(IBT(1))["2Q  CLAIM REJECTED BY CLEARINGHOUSE" D
+ .. S IBAUTO=1
+ .. S DIE=361,DA=+IBY,DR=".03////I" D ^DIE
  .. Q
  . ;
 …
  . I $G(IBAUTO),$P($G(^IBM(361,+IBY,0)),U,3)="I" D
  .. S DIE="^IBM(361,",DR=".09////2;.14////1;.1////F",DA=+IBY D ^DIE
+ .. I IB1,$P($G(^IBM(361,+IBY,0)),U,11) S Z="",Z0=0 F  S Z=$O(IBT(Z)) Q:Z=""!(Z0=1)  D
+ ... S Z0=$$PRINTUPD^IBCEU0($$UP^XLFSTR($G(IBT(Z))),$P($G(^IBM(361,+IBY,0)),U,11))
+ . ;
+ . D MSGLNSZ(.IBT) ; Convert Message Lines in IBT to be no longer than 70 chars
+ .. I IB1,$P($G(^IBM(361,+IBY,0)),U,11),$$PRINTUPD^IBCEU0($G(IBT(1)),$P($G(^IBM(361,+IBY,0)),U,11))
+ . ;
  . D WP^DIE(361,+IBY_",",1,"A","IBT")    ; file message text
  . ;
 …
  ; Don't move the raw data over, just move the text of the message
  F  S IBZ=$O(^IBA(364.2,IBTDA,2,IBZ)) Q:'IBZ  S IBZ1=$G(^(IBZ,0)) S IBDATA=($E(IBZ1,1,2)="##") Q:IBDATA  S IBZ0=IBZ0+1,IBT(IBZ0)=IBZ1 I 'IBCK S Z=$$CKREVU^IBCEM4(IBZ1,,,.IBCK),IBAUTO=$S(IBCK:0,Z:1,1:IBAUTO)
+ ;
+ ; Convert Message Lines in IBT to be no longer than 70 chars
+ D MSGLNSZ(.IBT)
+ Q
+ ;
 …
  ; which is an array of Converted Message Lines (with lines no more than 70 chars each)
+ ;
+ N LN,XARY,XARYLN,CNT,OUTMSG,TMPMSG,LDNGSP,LDNGSPN
+ S LN="",CNT=0 F  S LN=$O(MSG(LN)) Q:LN=""  D  ;
+ N LN,XARY,XARYLN,CNT,OUTMSG,TMPMSG,LDNGSP
+ S LN="",CNT=0
+ F  S LN=$O(MSG(LN)) Q:LN=""  D  ;
+ . ;
  . ; Find any leading spaces in original message line,
  . ; to be used if line got split below
  . S TMPMSG=$$TRIM^XLFSTR(MSG(LN),"L"," ")  ;Trim Leading Spaces
  . S LDNGSP=$P(MSG(LN),TMPMSG,1)  ;get leading spaces if any
  . S LDNGSPN=$L(LDNGSP) S:LDNGSPN>30 LDNGSP=$E(LDNGSP,1,30) ;make sure there are no more than 30 leading spaces
+ . ;
  . ; Converts a single line to multiple lines with a maximum width of 70 each
  . ; If line is 70 chars or less, this call returns the exact line
+ . K XARY D FSTRNG^IBJU1(TMPMSG,70-LDNGSPN,.XARY)
+ . K XARY D FSTRNG^IBJU1(MSG(LN),70,.XARY)
+ . ;
  . ; Scan lines and merge them into the final output array (OUTMSG)
  . ; On lines 2 and higher, add Leading Spaces found above, if any.
+ . S XARYLN="" F  S XARYLN=$O(XARY(XARYLN)) Q:XARYLN=""  S CNT=CNT+1,OUTMSG(CNT)=LDNGSP_XARY(XARYLN)
+ . S XARYLN=""
+ . F  S XARYLN=$O(XARY(XARYLN)) Q:XARYLN=""  S CNT=CNT+1,OUTMSG(CNT)=$S(XARYLN=1:XARY(XARYLN),1:LDNGSP_XARY(XARYLN))
+ ;
  ; Move the final Message Lines (OUTMSG) into MSG array to be returned
  K MSG M MSG=OUTMSG
+ Q
+ ;
+ Q  ;MSGLNSZ
+ ;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEU1.m

-              r628
+              r636
 IBCEU1 ;ALB/TMP - EDI UTILITIES FOR EOB PROCESSING ;10-FEB-99
  ;;2.0;INTEGRATED BILLING;**137,155,296,349,371**;21-MAR-94;Build 57
+ ;;2.0;INTEGRATED BILLING;**137,155,296,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
  . S (IBTOT,Z)=0
  . F  S Z=$O(^IBM(361.1,"ABS",IBIFN,IBCOBN,Z)) Q:'Z  D
+ .. ; HD64841 IB*2*371 - total up the payer paid amounts
+ .. S IBTOT=IBTOT+$P($G(^IBM(361.1,Z,1)),U,1)
+ .. S IBTOT=IBTOT+$P($G(^IBM(361.1,Z,1)),U,2)
  Q IBTOT
+ ;
 …
+ Q
+ ;
+COBOUT(IBXSAVE,IBXDATA,CL) ; build LCOB segment data
+ ; The IBXSAVE array used here is built by INS-2, then LCOB-1.9
+ ; This is basically the 361.115, but all the piece numbers here in this
+ ; local array are one higher than the pieces in subfile 361.115.
+COBOUT(IBXSAVE,IBXDATA,CL) ;
  N Z,M,N,P,PCCL
  S (N,Z,P)=0 F  S Z=$O(IBXSAVE("LCOB",Z)) Q:'Z  D
 …
+ ;
 COBPYRID(IBXIEN,IBXSAVE,IBXDATA) ; cob insurance company payer id
  N CT,N,NUM
+ N CT,Z,N,NUM
  K IBXDATA
  I '$D(IBXSAVE("LCOB")) G COBPYRX
  D ALLPAYID^IBCEF2(IBXIEN,.NUM,1)
+ S NUM=$G(NUM(1))
+ S NUM=$E(NUM_$J("",5),1,5)
+ S Z=$$COID^IBCEF2(IBXIEN),NUM=$G(NUM(1))
+ S:Z="" Z="0000"
+ S NUM=$E(NUM_$J("",5),1,5)_$E(Z_$J("",4),1,4)
  S (CT,N)=0
  F  S N=$O(IBXSAVE("LCOB",N)) Q:'N  S CT=CT+1,IBXDATA(CT)=NUM
 …
  ; The EOB is not eligible if the review status is not 3, or if there
  ; is no insurance sequence indicator, or if the EOB has been DENIED
+ ; and the patient responsibility for that EOB is $0 and that EOB is
+ ; not a split EOB.  Split EOB's need to be included (IB*2*371).
+ ; and the patient responsibility for that EOB is $0.
+ ;
  NEW ELIG,IBDATA,PTRESP
 …
  S IBDATA=$G(^IBM(361.1,IBEOB,0))
  I $P(IBDATA,U,4)'=1 G EOBELIGX      ; Only MRA EOB's for now
- I $D(^IBM(361.1,IBEOB,"ERR")) G EOBELIGX     ; filing error
  I $P(IBDATA,U,16)'=3 G EOBELIGX     ; review status - accepted-complete
  I '$P(IBDATA,U,15) G EOBELIGX       ; insurance sequence must exist
  S PTRESP=$P($G(^IBM(361.1,IBEOB,1)),U,2)     ; Pt Resp Amount for 1500s
  I $$FT^IBCEF(+IBDATA)=3 S PTRESP=$$PTRESPI^IBCECOB1(IBEOB)  ; for UBs
+ I PTRESP'>0,$P(IBDATA,U,13)=2,'$$SPLIT^IBCEMU1(IBEOB) G EOBELIGX     ; Denied & No Pt. Resp. & not a split MRA
+ I PTRESP'>0,$P(IBDATA,U,13)=2 G EOBELIGX     ; Denied & No Pt. Resp.
+ I $D(^IBM(361.1,IBEOB,"ERR")) G EOBELIGX     ; filing error
+ ;
  S ELIG=1

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEU3.m

-              r628
+              r636
+IBCEU3 ;ALB/TMP - EDI UTILITIES FOR 1500 CLAIM FORM ;12/29/05 9:58am
+ ;;2.0;INTEGRATED BILLING;**51,137,155,323,348,371**;21-MAR-94;Build 57
+ ;;Per VHA Directive 2004-038, this routine should not be modified.
+IBCEU3 ;ALB/TMP - EDI UTILITIES FOR 1500 CLAIM FORM ; 12/29/05 9:58am
+ ;;2.0;INTEGRATED BILLING;**51,137,155,323,348**;21-MAR-94;Build 5
+ ;
 BOX19(IBIFN) ; Returns the text that should print in box 19 of the CMS-1500
 …
  S IBSPEC=$$BILLSPEC(IBIFN)
  G:'IBPRT NPRT
- ; Check for chiropractic services
- I $P($G(^DGCR(399,IBIFN,"U3")),U,5)'="" S:$P($G(^DGCR(399,IBIFN,"U3")),U,4)'="" IBGO=$$LENOK("Last X-ray: "_$TR($$DATE^IBCF2($P(^DGCR(399,IBIFN,"U3"),U,4))," ","/"),.IB19)
- G:'IBGO BOX19Q
+ ;
  I "^25^65^73^67^48^"[(U_IBSPEC_U) D
  . K IBXDATA D F^IBCEF("N-DATE LAST SEEN",,,IBIFN)
 …
  . ;
  . Q:'IBGO
+ . I 'IBHOSP,$P($G(IBXSAVE(IBSUB,Z,"AUX")),U,3) S IBHOSP=1,IBGO=$$LENOK("Attending physician,not hospice employee",.IB19) Q
+ . I 'IBHOSP,$P($G(IBXSAVE(IBSUB,Z,"AUX")),U,3) D  Q
+ .. S IBHOSP=1,IBGO=$$LENOK("Attending physician,not hospice employee",.IB19)
+ . ;
+ . Q:'IBGO
+ . I 'IBXRAY,IBSPEC=35,$G(IBXSAVE(IBSUB,Z,"AUX"))'="" D  Q
+ .. ; Check for chiropratic services in claim type or specialty
+ .. S IBXRAY=1
+ .. S IBGO=$$LENOK($S($P(IBXSAVE(IBSUB,Z,"AUX"),U,2):"Last Xray:"_$$DATE^IBCF2($P(IBXSAVE(IBSUB,Z,"AUX"),U,2),0,1)_" ",1:"")_$S($P(IBXSAVE(IBSUB,Z,"AUX"),U,4)'="":"Level of Sublux:"_$P(IBXSAVE(IBSUB,Z,"AUX"),U,4),1:""),.IB19)
+ ;
  G:'IBGO BOX19Q
  K IBXDATA D F^IBCEF("N-SPECIAL PROGRAM",,,IBIFN)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEU6.m

-              r628
+              r636
 IBCEU6 ;ALB/ESG - EDI UTILITIES FOR EOB PROCESSING ;29-JUL-2003
  ;;2.0;INTEGRATED BILLING;**155,371**;21-MAR-94;Build 57
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**155**;21-MAR-94
+ ;
+ Q
+ ;
 …
  F  S A=$O(^IBM(361.1,"B",IBIFN,A)) Q:'A  D
  . I '$$EOBELIG^IBCEU1(A) Q   ; eob not eligible for secondary claim
- . I '$D(^IBM(361.1,A,15,"AC",IBI)) Q   ; this EOB does not reference VistA line# IBI
  . S IBA=0
  . S IBDATA=$G(^IBM(361.1,A,0))

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEXTRP.m

-              r628
+              r636
 IBCEXTRP ;ALB/JEH - VIEW/PRINT EDI EXTRACT DATA ;4/22/03 9:59am
  ;;2.0;INTEGRATED BILLING;**137,197,211,348,349,377**;21-MAR-94;Build 23
+IBCEXTRP ;ALB/JEH - VIEW/PRINT EDI EXTRACT DATA ; 4/22/03 9:59am
+ ;;2.0;INTEGRATED BILLING;**137,197,211,348,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
 INIT ;
  W !!,"This option will display the EDI extract data for a bill.",!
  N IBREC1,IBIEN,IBINC,DIC,X,Y,DIR,IB364IEN,IBVNUM,IBSEG,STOP,POP,DTOUT,DUOUT
+ N IBREC1,IBIEN,IBINC,DIC,X,Y,DIR,IB364IEN,IBVNUM
+ ;
  N DPTNOFZY S DPTNOFZY=1 ; Suppress PATIENT file fuzzy lookups
 …
  . W !!,"There is no batch # for this bill.  It has not been transmitted."
  S IBVNUM=$P($G(^IBA(364.1,IBVNUM,0)),U)
+ S DIR("A")="Include Fields With No Data?: ",DIR("B")="NO",DIR(0)="YA"
+ W ! D ^DIR K DIR
+ S DIR("A")="INCLUDE FIELDS WITH NO DATA?: ",DIR("B")="NO",DIR(0)="YA" D ^DIR K DIR
  I $D(DTOUT)!$D(DUOUT) G EXITQ
  S IBINC=+Y
+ ;
- ; IB*2*377 - esg - Ask for specific EDI segments to view
+ ;
- W !
- S DIR(0)="SA^A:All EDI Segments;S:Selected EDI Segments"
- S DIR("A")="Include (A)ll or (S)elected EDI Segments?: "
- S DIR("B")="All EDI Segments"
- D ^DIR K DIR
- I $D(DTOUT)!$D(DUOUT) G EXITQ
- I Y="A" G DEV                    ; all segments, skip to device prompt
+ ;
- W !
- K IBSEG
- S STOP=0
- F  D  Q:STOP
- . S DIR(0)="FO^3:4"
- . S DIR("A")=" Select EDI Segment"
- . I $D(IBSEG) S DIR("A")="Another EDI Segment"
- . S DIR("?")="Enter the name of the EDI segment to include."
- . D ^DIR K DIR
- . I $D(DTOUT)!$D(DUOUT) S STOP=1 Q
- . S Y=$$UP^XLFSTR(Y),Y=$$TRIM^XLFSTR(Y)   ; uppercase/trim spaces
- . I Y="" S STOP=1 Q
- . S IBSEG(Y)=""
- . Q
- I $D(DTOUT)!$D(DUOUT) G EXITQ
+ ;
 DEV ; - Select device
  N %ZIS,ZTRTN,ZTSAVE,ZTDESC
- W !
  S %ZIS="QM" D ^%ZIS G:POP EXITQ
  I $D(IO("Q")) D  G EXITQ
 …
  S IBFMTYP=$S(IBFMTYP=2:"CMS-1500",IBFMTYP=3:"UB-04",1:"OTHER"_"("_IBFMTYP_")")
  S IBILL=$S($$INPAT^IBCEF(IBIEN,1):"Inpt",1:"Oupt")_"/"_IBFMTYP
+ ;
  I $D(^TMP("IBXERR",$J)) D  G EXITQ
  . S IBERR=0 F  S IBERR=$O(^TMP("IBXERR",$J,IBERR)) Q:'IBERR  W !,$G(^TMP("IBXERR",$J,IBERR))
+ . Q
+ ;
+ F  S IBSEQ=$O(^IBA(364.6,"ASEQ",8,IBSEQ)) Q:'IBSEQ  I $$INCLUDE(IBSEQ) F  S IBPC=$O(^IBA(364.6,"ASEQ",8,IBSEQ,1,IBPC)) Q:'IBPC  F  S IBDA=$O(^IBA(364.6,"ASEQ",8,IBSEQ,1,IBPC,IBDA)) Q:'IBDA  D
+ . N IBOK,Z,IBMULT,DSP,IBDATA,PCD,SN
+ . S IBREC=$G(^IBA(364.6,IBDA,0))
+ . I $P(IBREC,U,11)=1 Q     ; calculate only field
+ . ;
+ . ; processing for piece 1 of this EDI segment to see if there is any
+ . ; other data that exists in this segment
+ F  S IBSEQ=$O(^IBA(364.6,"ASEQ",8,IBSEQ)) Q:'IBSEQ!(IBQUIT)  F  S IBPC=$O(^IBA(364.6,"ASEQ",8,IBSEQ,1,IBPC)) Q:'IBPC!(IBQUIT)  F  S IBDA=$O(^IBA(364.6,"ASEQ",8,IBSEQ,1,IBPC,IBDA)) Q:'IBDA!(IBQUIT)  S IBREC=$G(^IBA(364.6,IBDA,0)) D  Q:IBQUIT
+ . N IBOK,Z,IBMULT
+ . I $P(IBREC,U,11)=1 Q
  . I IBPC=1 S IBOK=0 D
  .. S Z=1 F  S Z=$O(^TMP("IBXDATA",$J,1,IBSEQ,1,Z)) Q:'Z  I $G(^(Z))'="" S IBOK=1 Q
+ .. I IBOK Q   ; data exists so include segment normally
+ .. S SN=$P($G(^TMP("IBXDATA",$J,1,IBSEQ,1,1)),U,1)   ; segment name
+ .. I SN="" S SN=$P($P(IBREC,U,10),"'",2)
+ .. S SN=SN_" (No Data - Record Not Sent)"
+ .. S $P(^TMP("IBXDATA",$J,1,IBSEQ,1,1),U,1)=SN
+ .. Q
+ . ;
+ . ; loop thru all multiple occurrences of this segment
+ .. I 'IBOK S $P(^TMP("IBXDATA",$J,1,IBSEQ,1,1),U)=$P($G(^TMP("IBXDATA",$J,1,IBSEQ,1,1)),U)_"  (NO DATA - RECORD NOT SENT)"
  . S IBMULT=0 F  S IBMULT=$O(^TMP("IBXDATA",$J,1,IBSEQ,IBMULT)) Q:'IBMULT   D
+ .. ;
+ .. ; field with no data; check user preference
+ .. I '$G(IBINC),$P($G(^TMP("IBXDATA",$J,1,IBSEQ,IBMULT,IBPC)),U,1)="" Q
+ .. ;
+ .. ; build display data
+ .. S PCD="["_IBPC_"] "      ; piece#
+ .. S DSP=$P(IBREC,U,10)     ; short description field
+ .. S IBDATA=$P($G(^TMP("IBXDATA",$J,1,IBSEQ,IBMULT,IBPC)),U,1)   ; data
+ .. S DSP=$J(PCD,5)_$$FO^IBCNEUT1(DSP,40)_": "_IBDATA
+ .. S ^TMP($J,"IBLINES",IBSEQ,IBMULT,IBPC)=DSP
+ .. Q
+ . Q
+ ;
+ S IBQUIT=0
+ .. I '$G(IBINC),$P($G(^TMP("IBXDATA",$J,1,IBSEQ,IBMULT,IBPC)),U)="" Q
+ .. S ^TMP($J,"IBLINES",IBSEQ,IBMULT,IBPC)=$E($P(IBREC,U,10)_$J("",30),1,30)_": "_$P($G(^TMP("IBXDATA",$J,1,IBSEQ,IBMULT,IBPC)),U)
+ .
  W:$E(IOST,1,2)["C-" @IOF ; initial form feed for screen print
  N IBFMTYP S IBFMTYP=$$FT^IBCEF(IBIEN)
 …
  S IBILL=$S($$INPAT^IBCEF(IBIEN,1):"Inpt",1:"Oupt")_"/"_IBFMTYP
  D HDR
  S Z=0 F  S Z=$O(^TMP($J,"IBLINES",Z)) Q:'Z!IBQUIT  S Z0=0 F  S Z0=$O(^TMP($J,"IBLINES",Z,Z0)) Q:'Z0!IBQUIT  S Z1=0 F  S Z1=$O(^TMP($J,"IBLINES",Z,Z0,Z1)) Q:'Z1!IBQUIT  D  Q:IBQUIT
  . I IBLINE>(IOSL-3) D HDR Q:IBQUIT
+ S Z=0 F  S Z=$O(^TMP($J,"IBLINES",Z)) Q:'Z  S Z0=0 F  S Z0=$O(^TMP($J,"IBLINES",Z,Z0)) Q:'Z0  S Z1=0 F  S Z1=$O(^TMP($J,"IBLINES",Z,Z0,Z1)) Q:'Z1  D  G:IBQUIT Q1
+ . D:IBLINE>(IOSL-5) HDR Q:IBQUIT
  . W !,^TMP($J,"IBLINES",Z,Z0,Z1)
  . S IBLINE=IBLINE+1
+ . I IBLINE>(IOSL-3) D HDR Q:IBQUIT
+ . ;
+ . ; end of segment add an extra line feed
+ . I '$O(^TMP($J,"IBLINES",Z,Z0,Z1)) W ! S IBLINE=IBLINE+1
+ . Q
+ ;
+ K ^TMP($J,"IBLINES")
+ G EXITQ
+ ;
+Q1 K ^TMP($J,"IBLINES")
+ Q
+ ;
 HDR ; - Report header
 …
+ ;
  S IBPG=IBPG+1
  W !,?25,"EDI Transmitted Bill Extract Data",!,"Bill #",?11,"Type",?27,"Patient Name",?52,"SSN",?57,$$FMTE^XLFDT(DT),?71,"Page: "_IBPG
+ W !!,?25,"EDI Transmitted Bill Extract Data",!,"Bill #",?11,"Type",?27,"Patient Name",?52,"SSN",?57,$$FMTE^XLFDT(DT),?71,"Page: "_IBPG
  W !,$TR($J("",IOM)," ","=")
  W !,$P(IBREC1,U)_" "_"("_IBILL_")",?27,$P($G(^DPT(+$P(IBREC1,U,2),0)),U),?52,$P($G(^DPT($P(IBREC1,U,2),0)),U,9),!
+ S IBLINE=6
+ S IBLINE=5
+ Q
+ ;
+ASK ;
+ I $E(IOST,1,2)'["C-" Q
+ N DIR,DIROUT,DIRUT,DTOUT,DUOUT
+ S DIR(0)="E" D ^DIR
+ I ($D(DIRUT))!($D(DUOUT)) S IBQUIT=1
+ Q
+ ;
 EXITQ ; - clean up and exit
  I $E(IOST,1,2)["C-",'$G(IBQUIT) K DIR S DIR(0)="E" W ! D ^DIR K DIR
+ I $E(IOST,1,2)["C-" K DIR S DIR(0)="E" W ! D ^DIR K DIR
  K ^TMP("IBXERR",$J),^TMP("IBXDATA",$J),IBXERR
  D CLEAN^DILF
 …
  ; IBFORM = the ien of the form in file 353
  ; IBLOCAL = 1 if OK to use local form, 0 if not
  N IBVNUM,IBL,IBINC,IBSEG
+ N IBVNUM,IBL
  D FORMPRE^IBCFP1
  S IBVNUM=$G(IBBATCH)
 …
+ Q
+ ;
-INCLUDE(IBSEQ) ; Function to determine if segment should be included or not
- N OK,LZ,SEGNAME
- S OK=1                   ; default is to include it
- I '$D(IBSEG) G INCLX     ; if nothing in array, then include all
- I '$D(^TMP("IBXDATA",$J,1,IBSEQ)) S OK=0 G INCLX        ; no data there
- S LZ=+$O(^TMP("IBXDATA",$J,1,IBSEQ,""))   ; first line# found in data
- S SEGNAME=$P($G(^TMP("IBXDATA",$J,1,IBSEQ,LZ,1)),U,1)   ; piece 1
- S SEGNAME=$$TRIM^XLFSTR(SEGNAME)
- I SEGNAME'="",'$D(IBSEG(SEGNAME)) S OK=0   ; don't include
-INCLX ;
- Q OK
+ ;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCF331.m

-              r628
+              r636
 IBCF331 ;ALB/ARH - UB92 HCFA-1450 (GATHER CODES CONT) ;25-AUG-1993
  ;;2.0;INTEGRATED BILLING;**52,210,309,389**; 21-MAR-94;Build 6
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**52,210,309**; 21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
+ ;
 …
  S IBZ="PROSTHETIC ITEMS:" D SET2
  S IBX=0 F  S IBX=$O(IBARRAY(IBX)) Q:IBX=""  S IBY=0 F  S IBY=$O(IBARRAY(IBX,IBY)) Q:'IBY  D
  . S IBZ=$$FMTE^XLFDT(IBX,2)_" "_$J($S($P(IBARRAY(IBX,IBY),U,2):"$"_$FN($P(IBARRAY(IBX,IBY),U,2),",",2),1:""),10)_"  "_$E($$PINB^IBCSC5B(+IBARRAY(IBX,IBY)),1,54) D SET2
+ . S IBZ=$$FMTE^XLFDT(IBX,2)_" "_$J($S($P(IBARRAY(IBX,IBY),U,2):"$"_$FN($P(IBARRAY(IBX,IBY),U,2),",",2),1:""),10)_"  "_$E($P($$PIN^IBCSC5B(IBY),U,2),1,54) D SET2
+ ;
 END Q

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCF4.m

-              r628
+              r636
 IBCF4 ;ALB/ARH - PRINT BILL ADDENDUM ;12-JAN-94
  ;;2.0;INTEGRATED BILLING;**52,137,199,309,389**;21-MAR-94;Build 6
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**52,137,199,309**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
 PRXA ;get bill number then print rx refill addendums for bills
 …
  . S IBY=$G(^IBA(362.5,IBPIFN,0)),IBYC="" Q:IBY=""
  . S IBYC=$$CHG(IBPIFN,5,.IBRC)
  . W !,$$FMTE^XLFDT(+$P(IBY,U,1),2),?11,$J($S(IBYC:"$"_$FN(IBYC,",",2),1:""),10),?24,$E($P(IBY,U,5),1,55)
+ . W !,$$FMTE^XLFDT(+$P(IBY,U,1),2),?11,$J($S(IBYC:"$"_$FN(IBYC,",",2),1:""),10),?24,$P($$PIN^IBCSC5B(+$P(IBY,U,3)),U,2)
  . S IBLN=IBLN+1 I IBLN>(IOSL-7) D PAUSE,HDR
  D:'IBQUIT PAUSE

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNADD.m

-              r628
+              r636
 IBCNADD ;ALB/AAS - ADDRESS RETRIEVAL ENGINE FOR FILE 399 ; 29-AUG-93
  ;;2.0;INTEGRATED BILLING;**52,80,377**;21-MAR-94;Build 23
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**52,80**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
 ADD(DA,IBCOB) ; -- Retrieve correct billing address for a bill, mailing address of Bill Payer
+ADD(DA) ; -- Retrive correct billing address for a bill, mailing address of Bill Payer
  ;    assumes that new policy field points to valid ins. policy
- ;    DA = ien to file 399
- ;    IBCOB = payer sequence PST or 123 (optional)
+ ;
  N X,Y,I,J,IB01,IB02,IBTYP,DFN,IBCNS,IBCDFN,IBCNT,IBAGAIN,IBFND,IBBILLTY,IBCHRGTY
  S IB02=""
  S DFN=$P($G(^DGCR(399,DA,0)),"^",2)
+ S IBCNS=+$P($G(^DGCR(399,DA,"MP")),U,1) G:'IBCNS MAINQ
+ S IBCDFN=$P($G(^DGCR(399,DA,"MP")),"^",2) I IBCDFN S IBCNS=+$G(^DPT(+DFN,.312,+IBCDFN,0))
  S IBBILLTY=$P($G(^DGCR(399,DA,0)),"^",5),IBCHRGTY=$P($$CHGTYPE^IBCU(DA),"^;",1)
+ ;
- S IBCNS=+$P($G(^DGCR(399,DA,"MP")),U,1)
- S IBCDFN=$P($G(^DGCR(399,DA,"MP")),U,2)
+ ;
- ; If a specific payer sequence was passed in, get the ins. company and the policy ptr
- ; No address returned for Medicare
- I $G(IBCOB)'="" D  I $$MCRWNR^IBEFUNC(IBCNS) G MAINQ
- . S IBCOB=$TR(IBCOB,"PST","123")
- . S IBCNS=+$P($G(^DGCR(399,DA,"I"_IBCOB)),U,1)
- . S IBCDFN=+$P($G(^DGCR(399,DA,"M")),U,IBCOB+11)
- . Q
+ ;
- I 'IBCNS G MAINQ
- I IBCDFN S IBCNS=+$G(^DPT(+DFN,.312,+IBCDFN,0))
  I '$D(^DIC(36,+IBCNS,0)) G MAINQ
+ ;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBCD.m

-              r628
+              r636
 IBCNBCD ;ALB/ARH-Ins Buffer: display/compare buffer and existing ins ;1 Jun 97
  ;;2.0;INTEGRATED BILLING;**82,251,361,371**;21-MAR-94;Build 57
+ ;;2.0;INTEGRATED BILLING;**82,251,361**;21-MAR-94;Build 9
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
  D DISPLAY(60.12,2.312,.2,"Coor of Benefits:")
  D DISPLAY(61.01,2.312,2.1,"Emp Sponsored?:")
- D DISPLAY(62.01,2.312,5.01,"Patient Id:")
+ ;
  I +$G(^IBA(355.33,IBBUFDA,61))!($$GET1^DIQ(2.312,IBEXTDA,2.1)="YES") D ESGHP

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBEE.m

-              r628
+              r636
 IBCNBEE ;ALB/ARH-Ins Buffer: add/edit existing entries in buffer ;1 Jun 97
  ;;2.0;INTEGRATED BILLING;**82,184,252,251,356,361,371,377**;21-MAR-94;Build 23
+ ;;2.0;INTEGRATED BILLING;**82,184,252,251,356,361**;21-MAR-94;Build 9
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
  ;;40.01:40.03;40.1;40.11;40.09;40.04:40.08
+ ;
 MRPOL ; Patient Policy fields asked of MCCR users in the Buffer Process options (all buffer policy fields except ESGHP,60.05,60.06 60.02-61.01
  ;;60.02;60.03;60.14PT. RELATIONSHIP TO INSURED;S IBZZ=X;60.04T;I IBZZ'="18" S Y="@111";60.07///1;60.08///@;60.09///@;62.01///@;S Y="@112";@111;60.07;60.08;60.13;62.01T;@112;60.1:60.12;.03;61.01
+MRPOL ; Patient Policy fields asked of MCCR users in the Buffer Process options (all buffer policy fields except ESGHP 60.02-61.01
+ ;;60.02;60.03;60.05;60.06//^S X=$S(X="v":"01",X="s":"02",1:"");S IBZZ=X;60.04;I IBZZ'="01" S Y="@111";60.07///1;60.08///@;60.09///@;S Y="@112";@111;60.07:60.09;60.13;@112;60.1:60.12;.03;61.01
+ ;
 OTINS ; Insurance Company fields asked of non-MCCR users entering buffer data from options outside IB (20.01-20.04,21.01-21.06)
 …
  ;;40.02;40.03;40.1;40.11;40.09
+ ;
 OTPOL ; Patient Policy fields asked of non-MCCR users entering buffer data from options outside IB (60.02-60.08)
  ;;60.02;60.03;60.14PT. RELATIONSHIP TO INSURED;S IBZZ=X;60.04T;I IBZZ'="18" S Y="@111";60.07///1;60.08///@;60.09///@;62.01///@;S Y="@112";@111;60.07;60.08;60.13;62.01T;@112
+OTPOL ; Patient Policy fields asked of non-MCCR users entering buffer data from options outside IB (60.02-60.09)
+ ;;60.02;60.03;60.05;60.06//^S X=$S(X="v":"01",X="s":"02",1:"");S IBZZ=X;60.04;I IBZZ'="01" S Y="@111";60.07///1;60.08///@;60.09///@;S Y="@112";@111;60.07:60.09;60.13;@112

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBLE.m

-              r628
+              r636
 IBCNBLE ;ALB/ARH-Ins Buffer: LM buffer entry screen ;1 Jun 97
  ;;2.0;INTEGRATED BILLING;**82,231,184,251,371**;21-MAR-94;Build 57
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**82,231,184,251**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
 EN ; - main entry point for list manager display
 …
+ ;
 BLD ; display buffer entry
  N IB0,IB20,IB40,IB60,IB61,IB62,IBL,IBLINE,ADDR,IBI,IBY
+ N IB0,IB20,IB40,IB60,IB61,IBL,IBLINE,ADDR,IBI,IBY
  S VALMCNT=0
+ S IB0=$G(^IBA(355.33,IBBUFDA,0)),IB20=$G(^IBA(355.33,IBBUFDA,20)),IB40=$G(^IBA(355.33,IBBUFDA,40))
+ S IB60=$G(^IBA(355.33,IBBUFDA,60)),IB61=$G(^IBA(355.33,IBBUFDA,61)),IB62=$G(^IBA(355.33,IBBUFDA,62))
+ S IB0=$G(^IBA(355.33,IBBUFDA,0)),IB20=$G(^IBA(355.33,IBBUFDA,20)),IB40=$G(^IBA(355.33,IBBUFDA,40)),IB60=$G(^IBA(355.33,IBBUFDA,60)),IB61=$G(^IBA(355.33,IBBUFDA,61))
+ ;
  D SET(" ") S IBY=$J("",26)_"Insurance Company Information" D SET(IBY,"B") S IBLINE=""
 …
  S IBL="Coord of Benefits: ",IBY=$$EXPAND^IBTRE(355.33,60.12,$P(IB60,U,12)) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,16)
  D SET(IBLINE) S IBLINE=""
  I $P(IB62,U)'="" S IBL="Patient Id: ",IBY=$P(IB62,U) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,13)
+ I $P(IB60,U,6)'="01"!($P(IB60,U,9)'="") S IBL="Insured's SSN: ",IBY=$P(IB60,U,9) S IBLINE=$$SETL("",IBY,IBL,18,13)
  I IBLINE'="" D SET(IBLINE) S IBLINE=""
+ ;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBMI.m

-              r628
+              r636
 IBCNBMI ;ALB/ARH-Ins Buffer: move buffer data to insurance files ;09 Mar 2005  11:42 AM
  ;;2.0;INTEGRATED BILLING;**82,184,246,251,299,345,361,371**;21-MAR-94;Build 57
+IBCNBMI ;ALB/ARH-Ins Buffer: move buffer data to insurance files ; 09 Mar 2005  11:42 AM
+ ;;2.0;INTEGRATED BILLING;**82,184,246,251,299,345,361**;21-MAR-94;Build 9
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
+ ;
 POLDR ;
  ;;2.312^60.02:62.01^8;3;1;6;16;17;3.01;3.05;4.01;4.02;.2;3.12;2.1;2.015;2.11;2.12;2.01:2.08;5.01
+ ;;2.312^60.02:61.12^8;3;1;6;16;17;3.01;3.05;4.01;4.02;.2;3.12;2.1;2.015;2.11;2.12;2.01:2.08
 POLFLD ; corresponding fields:  Buffer File (355.33) and Insurance Patient Policy file (2.312)
  ;;60.02^8^Effective Date^            ; Effective Date
 …
  ;;61.11^2.07^Emp Zip Code^1          ; Employer Claims Zip Code
  ;;61.12^2.08^Emp Phone^              ; Employer Claims Phone
- ;;62.01^5.01^Patient Id^             ; Patient Id
+ ;
 POLA ; auto set fields

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNEBF.m

-              r628
+              r636
 IBCNEBF ;DAOU/ALA - Create an Entry in the Buffer File ;20-JUN-2002
  ;;2.0;INTEGRATED BILLING;**184,271,361,371**;21-MAR-94;Build 57
+ ;;2.0;INTEGRATED BILLING;**184,271,361**;21-MAR-94;Build 9
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
+ ;
+ ;
  NEW VBUF,IEN,INAME,PNAME,IIEN,GNUMB,GNAME,SUBID,PPHONE,PATID
+ NEW VBUF,IEN,INAME,PNAME,IIEN,GNUMB,GNAME,SUBID,PPHONE
  NEW BPHONE,EFFDT,EXPDT,WHO,REL,IDOB,ISSN,COB,TQIEN,RDATA,ISEX,NAME
  NEW MSG,XMSUB,MSGP,INSDATA,PCE,BFD,BFN,INSPCE,ESGHPARR
 …
  S NAME=$P($G(^DPT(DFN,.312,IRIEN,0)),U,17)
  S SUBID=$P($G(^DPT(DFN,.312,IRIEN,0)),U,2)
- S PATID=$P($G(^DPT(DFN,.312,IRIEN,5)),U,1)
  S WHO=$P($G(^DPT(DFN,.312,IRIEN,0)),U,6)
  S COB=$P($G(^DPT(DFN,.312,IRIEN,0)),U,20)
 …
  S COB=$P(RDATA,U,13)
  S SUBID=$P(RDATA,U,5)
- S PATID=$P(RDATA,U,18)
  S GNAME=$P(RDATA,U,6)
  S GNUMB=$P(RDATA,U,7)
 …
+ ;
  D FIL
  K DFN,VBUF,IEN,IRIEN,INAME,PNAME,IIEN,GNUMB,GNAME,SUBID,PPHONE,PATID
+ K DFN,VBUF,IEN,IRIEN,INAME,PNAME,IIEN,GNUMB,GNAME,SUBID,PPHONE
  K BPHONE,EFFDT,EXPDT,WHO,REL,IDOB,ISSN,COB,TQIEN,RDATA,ISEX,NAME
  K ADD,%DT,D0,DG,DIC,DISYS,DIW,IENS
 …
  . S VBUF(60.07)=NAME  ; Name of Insured
  . S VBUF(60.04)=SUBID  ; Subscriber ID
- . S VBUF(62.01)=PATID  ; Patient/Member ID
  . S VBUF(20.04)=PPHONE  ; Precertification Phone
  . S VBUF(20.03)=BPHONE  ; Billing Phone
 …
  . S MSG(4)=" Patient DFN = "_$G(DFN)
  . S MSG(5)=" Pt Ins Record IEN = "_$G(IRIEN)
  . S MSG(6)="Please log a Remedy Ticket for this problem."
+ . S MSG(6)="Please log a NOIS for this problem."
  . S XMSUB="Error creating Buffer Entry."
  . D MSG^IBCNEUT5(MSGP,XMSUB,"MSG(")

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNQ.m

-              r628
+              r636
+IBCNQ ;ALB/MJB - MCCR PATIENT BILLING INQUIRY ;13 JUN 88 13:52
+ ;;2.0;INTEGRATED BILLING;**51,320,377**;21-MAR-94;Build 23
+ ;;Per VHA Directive 2004-038, this routine should not be modified.
+IBCNQ ;ALB/MJB - MCCR PATIENT BILLING INQUIRY ;7:37 PM  30 Jan 2008
+ ;;2.0;INTEGRATED BILLING;**51,320;VWEHR1**;WorldVistA 30-Jan-08
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
  ;MAP TO DGCRNQ
 …
 VIEW ;
  ;***
+ ;S XRTL=$ZU(0),XRTN="IBCNQ-2" D T0^%ZOSV ;start rt clock
  F I=0,"S","U","U1" S IB(I)=$G(^DGCR(399,IBIFN,I))
  S DFN=$P(IB(0),"^",2),IBSTAT=$P(IB(0),"^",13),IBBNO=$$BN^PRCAFN(IBIFN),IBPAGE=0 S:IBBNO=-1 IBBNO=$S($D(IBIL):IBIL,1:$P(IB(0),"^"))
 …
+ ;
  S IBUN="UNSPECIFIED",IBUK="UNKNOWN USER"
  W !,"Bill Status",?15,": ",$S(IBSTAT=1:"ENTERED/NOT REVIEWED",IBSTAT=2:"MRA REQUESTED",IBSTAT=3:"AUTHORIZED",IBSTAT=4:"PRINTED/TRANSMITTED",IBSTAT=7:"CANCELLED",1:IBUN)," - RECORD IS ",$S(IBSTAT=1:"",1:"UN"),"EDITABLE"
+ W !,"Bill Status",?15,": ",$S(IBSTAT=1:"ENTERED/NOT REVIEWED",IBSTAT=2:"MRA REQUESTED",IBSTAT=3:"AUTHORIZED",IBSTAT=4:"PRINTED/TRANSMITTED",IBSTAT=7:"CANCELLED",1:IBUN)," - RECORD IS ",$S(IBSTAT<3:"",1:"UN"),"EDITABLE"
  W !,"Rate Type",?15,": ",$S($P(IB(0),"^",7)="":IBUN,'$D(^DGCR(399.3,$P(IB(0),"^",7),0)):IBUN,1:$P(^DGCR(399.3,$P(IB(0),"^",7),0),"^"))
  W:+$P(^IBE(350.9,1,1),"^",22) !,"Form Type",?15,": ",$S($P($G(^IBE(353,+$P(IB(0),"^",19),0)),"^")]"":$P(^(0),"^"),1:IBUN)
 …
  S IBUN="UNSPECIFIED",IBUK="UNKNOWN USER"
  I IB("S")']"" W !,"Past actions of this billing record unspecified." G DISPQ
  S IBX="Entered^^^^^^MRA Requested^^^Authorized^^First Printed^^Last Printed^^^Cancelled"
  F I=1,7,10,12,14,17 I $P(IB("S"),U,I)]"" D:IBAC[7&($Y>(IOSL-4)) HDR Q:$S(IBAC'[7:0,1:IBQUIT)  D DISP1
+ S IBX="Entered^^^^^^MRA Requested^^^Authorized^^^^Last Printed^^^Cancelled"
+ F I=1,10,14,17 I $P(IB("S"),U,I)]"" D:IBAC[7&($Y>(IOSL-4)) HDR Q:$S(IBAC'[7:0,1:IBQUIT)  D DISP1
+ ;
  ;Patch 320 - Added call to retrieve claim clone history.
 …
  ; now go backwards for claim cloning history all the way back
  S IBBCH=IBCURR
+ F  S IBBCH=$Q(@IBBCH,-1) Q:IBBCH=""  D
+ ;
+ ;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
+ ;
+ ;F  S IBBCH=$Q(@IBBCH,-1) Q:IBBCH=""  D
+ F  S IBBCH=$$Q^VWUTIL($NA(@IBBCH),-1) Q:IBBCH=""  D
+ . ;
+ . ;END CHANGE
+ . ;
  . N IBX,TS1,TS2 S IBX=@IBBCH
  . I IBINDENT S TS1=4,TS2=19     ; set tab stops

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNRDV.m

-              r628
+              r636
 IBCNRDV ;OAKFO/ELZ - INSURANCE INFORMATION EXCHANGE VIA RDV ;27-MAR-03
  ;;2.0;INTEGRATED BILLING;**214,231,361,371**;21-MAR-94;Build 57
+IBCNRDV ;OAKFO/ELZ - INSURANCE INFORMATION EXCHANGE VIA RDV;27-MAR-03
+ ;;2.0;INTEGRATED BILLING;**214,231,361**;21-MAR-94;Build 9
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
  S IBD(0)=$G(IBY(0))
+ ;
  ; where n starts at 1 and increments to 7 for each insurance company
+ ; where n starts at 1 and increments 6 for each insurance company
  ; IBD(n) = 355.33, zero node format
  ; IBD(n+1) = 355.33, 20 node format
 …
  ; IBD(n+4) = 355.33, 60 node format
  ; IBD(n+5) = 355.33, 61 node format
- ; IBD(n+6) = 355.33, 62 node format
+ ;
  S IBP="|"
 …
  . S IBZ=$P($G(IBY(IBI,+IBT)),"^",$P(IBT,IBP,2)) ; set the existing data
  . I $L($P(IBT,IBP,6)) X $P(IBT,IBP,6) ; output transform
  . S $P(IBD(IBI-1*7+$P(IBT,IBP,3)),"^",$P(IBT,IBP,4))=IBZ ; set data IBD
+ . S $P(IBD(IBI-1*6+$P(IBT,IBP,3)),"^",$P(IBT,IBP,4))=IBZ ; set data IBD
+ Q
+ ;
 …
  ;;4|1|5|10|60.1;primary care provider
  ;;4|2|5|11|60.11;primary provider phone
- ;;5|1|7|1|62.01;patient id
  ;;355.3|2|4|1|40.01;is this a group policy
  ;;355.3|3|4|2|40.02;group name

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNS1.m

-              r628
+              r636
 IBCNS1 ;ALB/AAS - INSURANCE MANAGEMENT SUPPORTED FUNCTIONS ;22-JULY-91
  ;;2.0;INTEGRATED BILLING;**28,60,52,85,107,51,137,240,371**;21-MAR-94;Build 57
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**28,60,52,85,107,51,137,240**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
 INSURED(DFN,IBINDT) ; -- Is patient insured
 …
  ;           var(x,3) =: ^dpt(dfn,.312,x,3)
  ;           var(x,4) =: ^dpt(dfn,.312,x,4)
- ;           var(x,5) =: ^dpt(dfn,.312,x,5)
  ;       var(x,355.3) =: ^iba(355.3,$p(var(x,0),"^",18),0)
  ;       var("S",COB sequence,x) =: (null) as an xref for COB
 …
  .S @VAR@(X,3)=$G(^DPT(DFN,.312,X,3))
  .S @VAR@(X,4)=$G(^DPT(DFN,.312,X,4))
- .S @VAR@(X,5)=$G(^DPT(DFN,.312,X,5))
  .S @VAR@(X,355.3)=$G(^IBA(355.3,+$P($G(^DPT(DFN,.312,X,0)),"^",18),0))
  .I $G(SOP) D

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC.m

-              r628
+              r636
 IBCNSC ;ALB/NLR - INSURANCE COMPANY EDIT ;6/1/05 9:42am
  ;;2.0;INTEGRATED BILLING;**46,137,184,276,320,371**;21-MAR-94;Build 57
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+IBCNSC ;ALB/NLR - INSURANCE COMPANY EDIT ; 6/1/05 9:42am
+ ;;2.0;INTEGRATED BILLING;**46,137,184,276,320**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
  ;also used for IA #4694
 …
  N OFFSET,START,IBCNS14,IBADD
  S IBCNS14=$$ADDRESS^IBCNSC0(IBCNS,.14,7)
  S START=48,OFFSET=2
+ S START=40,OFFSET=2
  D SET^IBCNSP(START,OFFSET+25," Appeals Office Information ",IORVON,IORVOFF)
  D SET^IBCNSP(START+1,OFFSET," Company Name: "_$P($G(^DIC(36,+$P(IBCNS14,"^",7),0)),"^",1))
 …
  N OFFSET,START,IBCNS15,IBADD
  S IBCNS15=$$ADDRESS^IBCNSC0(IBCNS,.15,8)
  S START=55,OFFSET=2
+ S START=47,OFFSET=2
  D SET^IBCNSP(START,OFFSET+25," Inquiry Office Information ",IORVON,IORVOFF)
  D SET^IBCNSP(START+1,OFFSET," Company Name: "_$P($G(^DIC(36,+$P(IBCNS15,"^",7),0)),"^",1))
 …
  Q OK
+ ;
-DUPQUAL(IBCNS,QUAL,FIELD) ; input transform to make sure that the sam qualifier is not used twice for
- ; payer secondary IDs.  There are two sets of fields in file 36 that can not be duplicated.
- ; 6.01 EDI INST SECONDARY ID QUAL(1) can not be the same as 6.03 EDI INST SECONDARY ID QUAL(2)
- ; 6.05 EDI PROF SECONDARY ID QUAL(1) can not be the same as 6.07 EDI PROF SECONDARY ID QUAL(2)
+ ;
- ; Input:
- ; IBCNS is the insurance company internal number
- ; QUAL  is the internal code of the value being input.
- ; FIELD is the field it is being compare with.
+ ;
- ; Returns:
- ; TRUE/1 if they are the same (duplicate)
- ; FALSE/0 if they are not
+ ;
- Q:$G(QUAL)="" 0  ; should not happen because this is invoked as an input transform
- Q:'+$G(IBCNS) 1  ; stop from editing through fileman
- N DUP
- S DUP=$$GET1^DIQ(36,+$G(IBCNS)_",",+$G(FIELD),"I")
- D CLEAN^DILF
- Q QUAL=DUP

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC0.m

-              r628
+              r636
 IBCNSC0 ;ALB/NLR - INSURANCE COMPANY EDIT -  ;12-MAR-1993
  ;;2.0; INTEGRATED BILLING ;**371**; 21-MAR-94;Build 57
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+IBCNSC0 ;ALB/NLR - INSURANCE COMPANY EDIT -  ; 12-MAR-1993
+ ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
 CLAIMS1 ; display Inpatient Claims information
  N OFFSET,START,IBCNS12,IBADD
  S START=27,OFFSET=2
+ S START=21,OFFSET=2
  D SET^IBCNSP(START,OFFSET+20," Inpatient Claims Office Information ",IORVON,IORVOFF)
  S IBCNS12=$$ADDRESS(IBCNS,.12,5)
 …
+ ;
  N OFFSET,START,IBCNS16,IBADD
  S START=34,OFFSET=2
+ S START=27,OFFSET=2
  D SET^IBCNSP(START,OFFSET+20," Outpatient Claims Office Information ",IORVON,IORVOFF)
  S IBCNS16=$$ADDRESS(IBCNS,.16,6)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC01.m

-              r628
+              r636
 IBCNSC01 ;ALB/NLR - INSURANCE COMPANY EDIT ;6/1/05 10:06am
  ;;2.0;INTEGRATED BILLING;**52,137,191,184,232,320,349,371**;21-MAR-94;Build 57
+IBCNSC01 ;ALB/NLR - INSURANCE COMPANY EDIT ; 6/1/05 10:06am
+ ;;2.0;INTEGRATED BILLING;**52,137,191,184,232,320,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
  D SET^IBCNSP(START+6,OFFSET+1,"Amb. Sur. Rev. Code: "_$P(IBCNS0,"^",9))
  D SET^IBCNSP(START+7,OFFSET+1,"Rx Refill Rev. Code: "_$P(IBCNS0,"^",15))
+ D SET^IBCNSP(START+8,OFFSET+3,"Filing Time Frame: "_$P(IBCNS0,"^",12))
+ D SET^IBCNSP(START+9,OFFSET+4,"Type Of Coverage: "_$$EXPAND^IBTRE(36,.13,+$P(IBCNS0,U,13)))
+ D SET^IBCNSP(START+10,OFFSET+3,"Primary Form Type: "_$$EXPAND^IBTRE(36,.14,$P(IBCNS0,"^",14)))
+ ;
+ S OFFSET=45
+ D SET^IBCNSP(START+1,OFFSET+3,"Filing Time Frame: "_$P(IBCNS0,"^",12))
+ D SET^IBCNSP(START+2,OFFSET+4,"Type Of Coverage: "_$$EXPAND^IBTRE(36,.13,+$P(IBCNS0,U,13)))
+ D SET^IBCNSP(START+3,OFFSET+7,"Billing Phone: "_$P(IBCNS13,"^",2))
+ D SET^IBCNSP(START+4,OFFSET+2,"Verification Phone: "_$P(IBCNS13,"^",4))
+ D SET^IBCNSP(START+5,OFFSET+2,"Precert Comp. Name: "_$P($G(^DIC(36,+$P(IBCNS13,"^",9),0)),"^",1))
+ D SET^IBCNSP(START+6,OFFSET+7,"Precert Phone: "_$$PHONE(IBCNS13))
+ I +IBCNS3=2 D SET^IBCNSP(START+7,OFFSET,"Max # Test Bills/Day: "_$P(IBCNS3,U,6))
+ ;
+ S START=11,OFFSET=2
+ D SET^IBCNSP(START,OFFSET+28," EDI Parameters ",IORVON,IORVOFF)
+ D SET^IBCNSP(START+1,OFFSET+13,"Transmit?: "_$S(+IBCNS3=1:"YES-LIVE",+IBCNS3=2:"TEST ONLY",1:"NO"))
+ D SET^IBCNSP(START+2,OFFSET+1,"Inst Payer Primary ID: "_$P(IBCNS3,U,4))
+ D SET^IBCNSP(START+3,OFFSET,"Inst Payer Sec ID Qual: "_$$GET1^DIQ(36,+IBCNS,6.01))
+ D SET^IBCNSP(START+4,OFFSET+5,"Inst Payer Sec ID: "_$$GET1^DIQ(36,+IBCNS,6.02))
+ D SET^IBCNSP(START+5,OFFSET,"Inst Payer Sec ID Qual: "_$$GET1^DIQ(36,+IBCNS,6.03))
+ D SET^IBCNSP(START+6,OFFSET+5,"Inst Payer Sec ID: "_$$GET1^DIQ(36,+IBCNS,6.04))
+ D SET^IBCNSP(START+7,OFFSET+12,"Bin Number: "_$P($G(^DIC(36,+IBCNS,3)),"^",3)) ;
+ ;
+ S OFFSET=41
+ D SET^IBCNSP(START+1,OFFSET+8," Insurance Type: "_$$EXPAND^IBTRE(36,3.09,+$P(IBCNS3,U,9)))
+ D SET^IBCNSP(START+2,OFFSET+1," Prof Payer Primary ID: "_$P(IBCNS3,U,2))
+ D SET^IBCNSP(START+3,OFFSET," Prof Payer Sec ID Qual: "_$$GET1^DIQ(36,+IBCNS,6.05))
+ D SET^IBCNSP(START+4,OFFSET+5," Prof Payer Sec ID: "_$$GET1^DIQ(36,+IBCNS,6.06))
+ D SET^IBCNSP(START+5,OFFSET," Prof Payer Sec ID Qual: "_$$GET1^DIQ(36,+IBCNS,6.07))
+ D SET^IBCNSP(START+6,OFFSET+5," Prof Payer Sec ID: "_$$GET1^DIQ(36,+IBCNS,6.08))
+ N START,OFFSET
+ S START=1,OFFSET=45
+ D SET^IBCNSP(START+1,OFFSET+7,"Billing Phone: "_$P(IBCNS13,"^",2))
+ D SET^IBCNSP(START+2,OFFSET+2,"Verification Phone: "_$P(IBCNS13,"^",4))
+ D SET^IBCNSP(START+3,OFFSET+2,"Precert Comp. Name: "_$P($G(^DIC(36,+$P(IBCNS13,"^",9),0)),"^",1))
+ D SET^IBCNSP(START+4,OFFSET+7,"Precert Phone: "_$$PHONE(IBCNS13))
+ D SET^IBCNSP(START+5,OFFSET+6,"   *** EDI Parameters ***   ",IOINHI,IOINORM)
+ D SET^IBCNSP(START+6,OFFSET+11,"Transmit?: "_$S(+IBCNS3=1:"YES-LIVE",+IBCNS3=2:"TEST ONLY",1:"NO"))
+ D SET^IBCNSP(START+7,OFFSET+7,"Inst Payer ID: "_$P(IBCNS3,U,4))
+ D SET^IBCNSP(START+8,OFFSET+7,"Prof Payer ID: "_$P(IBCNS3,U,2))
+ D SET^IBCNSP(START+9,OFFSET+6,"Insurance Type: "_$$EXPAND^IBTRE(36,3.09,+$P(IBCNS3,U,9)))
+ D SET^IBCNSP(START+10,OFFSET+10,"Bin Number: "_$P($G(^DIC(36,+IBCNS,3)),"^",3))
+ I +IBCNS3=2 D SET^IBCNSP(START+11,OFFSET,"Max # Test Bills/Day: "_$P(IBCNS3,U,6))
+ Q
+ ;
 …
  S IBCNS11=$G(^DIC(36,+IBCNS,.11))
  S IBCNS13=$G(^DIC(36,+IBCNS,.13))
  S START=21,OFFSET=25
+ S START=15,OFFSET=25
  D SET^IBCNSP(START,OFFSET," Main Mailing Address ",IORVON,IORVOFF)
  N OFFSET S OFFSET=2

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC02.m

-              r628
+              r636
 IBCNSC02 ;ALB/ESG - Insurance Company parent/child management ;01-NOV-2005
  ;;2.0;INTEGRATED BILLING;**320,371**;21-MAR-94;Build 57
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**320**;21-MAR-1994
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
+ Q
 …
  I PCFLG="P" S PCDESC="Parent"
  S TITLE=" Associated Insurance Companies "
  S (START,IBLINE)=62
+ S (START,IBLINE)=54
  S OFFSET=(40-($L(TITLE)/2))\1+1
  D SET^IBCNSP(START,OFFSET,TITLE,IORVON,IORVOFF)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC1.m

-              r628
+              r636
 IBCNSC1 ;ALB/NLR - IBCNS INSURANCE COMPANY ;23-MAR-93
  ;;2.0;INTEGRATED BILLING;**62,137,232,291,320,348,349,371**;21-MAR-94;Build 57
+ ;;2.0;INTEGRATED BILLING;**62,137,232,291,320,348,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
  I $G(IBY)=",12," D FACID
  F Z=1,2,4,9,13,14 S IBEDIKEY(Z)=$P($G(^DIC(36,+IBCNS,3)),U,Z)   ; save EDI data fields
+ F Z=1:1:8 S IBEDIKEY(Z,6)=$P($G(^DIC(36,+IBCNS,6)),U,Z)   ; save EDI data fields
+ I $G(IBY)'=",12," N DIE,DA,DR S DIE="^DIC(36,",(DA,Y)=IBCNS,DR="[IBEDIT INS CO1]" D ^DIE K DIE S:$D(Y) IB("^")=1 D:$TR($P($G(^DIC(36,IBCNS,6)),U,1,8),U)]"" CUIDS(IBCNS)
+ I $G(IBY)'=",12," N DIE,DA,DR S DIE="^DIC(36,",(DA,Y)=IBCNS,DR="[IBEDIT INS CO1]" D ^DIE K DIE I $D(Y) S IB("^")=1
  I $G(IBY)=",12," D EDITID^IBCEP(+IBCNS)
  I $F(",6,13,",$G(IBY)) D PARENT^IBCNSC02(+IBCNS)   ; parent/child management
 …
  N OFFSET,START,IBCNS18,IBADD
  S IBCNS18=$$ADDRESS^IBCNSC0(IBCNS,.18,11)
  S START=41,OFFSET=2
+ S START=34,OFFSET=2
  D SET^IBCNSP(START,OFFSET+19," Prescription Claims Office Information ",IORVON,IORVOFF)
  D SET^IBCNSP(START+1,OFFSET," Company Name: "_$P($G(^DIC(36,+$P(IBCNS18,"^",7),0)),"^",1))
 …
  I IBINS,IBPTYP S X=$P($G(^IBA(355.91,+$O(^IBA(355.91,"AC",IBINS,IBPTYP,"*N/A*","")),0)),U,7)
  Q X
+ ;
-CUIDS(IBCNS) ;
- N DIE,DA,DR,PIECE,DAT6,Y
- S DAT6=$P(^DIC(36,IBCNS,6),U,1,8) ; get the Payer IDs
+ ;
- ; Make sure each qualifier has an ID and vice versa
- F PIECE=1,3,5,7 D
- . I $TR($P(DAT6,U,PIECE,PIECE+1),U)="" Q  ; both blank
- . I $P(DAT6,U,PIECE)]"",$P(DAT6,U,PIECE+1)]"" Q  ; both have data
- . S DIE="^DIC(36,",(DA,Y)=IBCNS,DR="6.0"_$S($P(DAT6,U,PIECE)]"":PIECE,1:PIECE+1)_"////@"
- . D ^DIE K DIE
+ ;
- S DAT6=$P($G(^DIC(36,IBCNS,6)),U,1,8) ; get the Payer IDs again since they may have changed above.
+ ;
- ; Make sure the first pair of ID/Qual are populated if the 2nd pair is.  If not, move em over.
- ; This is done for institutional then professional
- F PIECE=1,5 D
- . I $P(DAT6,U,PIECE)]"" Q  ; already has set one
- . I $P(DAT6,U,PIECE+2)="" Q  ; has no second set
- . S DIE="^DIC(36,",(DA,Y)=IBCNS
- . ; deleting the qualifier triggers deletion of the ID
- . S DR="6.0"_PIECE_"////"_$P(DAT6,U,PIECE+2)_";6.0"_(PIECE+1)_"////"_$P(DAT6,U,PIECE+3)_";6.0"_(PIECE+2)_"////@"
- . D ^DIE K DIE
+ Q

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSEH.m

-              r628
+              r636
 IBCNSEH ;ALB/AAS - EXTENDED HELP FOR INSURANCE MANAGEMENT ;28-MAY-93
  ;;2.0;INTEGRATED BILLING;**6,28,371**;21-MAR-94;Build 57
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+IBCNSEH ;ALB/AAS - EXTENDED HELP FOR INSURANCE MANAGEMENT - 28-MAY-93
+ ;;Version 2.0 ; INTEGRATED BILLING ;**6,28**; 21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
 INS ; -- Help for Insurance Type
 …
 PAT ; -- Help for entering patient specific information
  Q:'$G(IBCNSEH)
+ W !!,"Now you may enter the patient specific policy information.",!
+ W !!,"Now you may enter the patient specific policy information."
+ W !,"Most of these fields will be familiar to experienced users.  The field"
+ W !,"'SUBSCRIBER ID' used to be called 'INSURANCE NUMBER' and "
+ W !,"has been modified to allow entering just 'SS' to retrieve"
+ W !,"the patients SSN.  This field is the identifier for the policy or patient"
+ W !,"that the carrier uses.  See the new help.",!
+ Q
 POL ; -- Help for policy specific information

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSM32.m

-              r628
+              r636
 IBCNSM32 ;ALB/AAS - INSURANCE MANAGEMENT - POLICY EDIT ;23-JAN-95
  ;;2.0;INTEGRATED BILLING;**28,40,52,85,103,133,361,371**;21-MAR-94;Build 57
+IBCNSM32 ;ALB/AAS - INSURANCE MANAGEMENT - POLICY EDIT ; 23-JAN-95
+ ;;2.0;INTEGRATED BILLING;**28,40,52,85,103,133,361**;21-MAR-94;Build 9
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
+ ;
  N IBAD,IBDIF,DA,DR,DIC,DIE,DGSENFLG S DGSENFLG=1
+ S DIE="^DPT("_DFN_",.312,",DA(1)=DFN,DA=IBCDFN
+ S DR="S IBAD="""";8;@333;3;D FUTURE^IBCNSM31;6;S IBAD=X;K X I '$$VET^IBCNSU1() S Y=""@10"";17///^S X=$P(^DPT(DFN,0),U);16///^S X=""01"""
+ ;S DR="S IBAD="""";8;@333;3;D FUTURE^IBCNSM31;6;S IBAD=X;I IBAD'=""v"" S Y=""@10"";17"_$S($$VET^IBCNSU1():"///^S X="""_$P(^DPT(DFN,0),U,1)_"""",1:"//"_);16///^S X=""01"""
+ S DR=DR_";S Y=""@20"";@10;17;16//^S X=$S(IBAD=""s"":""02"",1:"""");@20;1;3.01;3.12;1.09//;I $G(IBREG) S Y=""@99"";.2;4.01;4.02;@99"
+ I $G(IBREG),$D(^XUSEC("IB INSURANCE SUPERVISOR",DUZ)) S DR=".01//;"_DR
  L +^DPT(DFN,.312,+IBCDFN):5 I '$T D LOCKED^IBTRCD1 G PATPOLQ
+ ;
+ D EDIT^IBCNSP1(DFN,IBCDFN,.IBQUIT)    ; IB*371 edit 2.312 subfile data
+ ;
+ ; If the 2.312 subfile entry was deleted then unlock and get out
+ I '$D(^DPT(DFN,.312,IBCDFN,0)) L -^DPT(DFN,.312,+IBCDFN) G PATPOLQ
+ D ^DIE I $D(Y)!($D(DTOUT)) S IBQUIT=1
+ I '$D(DA) S IBQUIT=1 G PATPOLQ
+ ;
  ; -- if the company was changed, change the policy plan

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP.m

-              r628
+              r636
 IBCNSP ;ALB/AAS - INSURANCE MANAGEMENT - EXPANDED POLICY ;05-MAR-1993
  ;;2.0;INTEGRATED BILLING;**6,28,43,52,85,251,363,371**;21-MAR-94;Build 57
+ ;;2.0;INTEGRATED BILLING;**6,28,43,52,85,251,363**;21-MAR-94;Build 35
  ;;Per VHA Directive 2004-038, this routine should not be modified.
 % ;
 EN ; -- main entry point for IBCNS EXPANDED POLICY
- N IB1ST
  K VALMQUIT,IBPPOL
  S IBTOP="IBCNSP"
 …
  K ^TMP("IBCNSVP",$J),^TMP("IBCNSVPDX",$J)
  D KILL^VALM10()
+ F I=1:1:20 D BLANK(.I)    ; start with 20 blank lines
+ N IBCDFND,IBCDFND1,IBCDFND2,IBCDFND4,IBCDFND5
+ S IBCDFND=$G(^DPT(DFN,.312,$P(IBPPOL,U,4),0)),IBCDFND1=$G(^(1)),IBCDFND2=$G(^(2)),IBCDFND4=$G(^(4)),IBCDFND5=$G(^(5))
+ F I=1:1:50 D BLANK(.I)
+ S VALMCNT=50
+ N IBCDFND,IBCDFND1,IBCDFND2,IBCDFND4
+ S IBCDFND=$G(^DPT(DFN,.312,$P(IBPPOL,U,4),0)),IBCDFND1=$G(^(1)),IBCDFND2=$G(^(2)),IBCDFND4=$G(^(4))
  S IBCPOL=+$P(IBCDFND,U,18),IBCNS=+IBCDFND,IBCDFN=$P(IBPPOL,U,4)
  S IBCPOLD=$G(^IBA(355.3,+$P(IBCDFND,U,18),0)),IBCPOLD1=$G(^(1))
  S IBCPOLD2=$G(^IBA(355.3,+$G(IBCPOL),6)) ;; Daou/EEN adding BIN and PCN
+ ;
+ D POLICY^IBCNSP0                   ; plan information
+ D INS^IBCNSP0                      ; insurance company
+ D UR                               ; utilization review info
+ D EFFECT                           ; effective dates & source of info
+ D SUBSC^IBCNSP01                   ; subscriber info
+ D EMP                              ; subscriber's employer info
+ D SPON^IBCNSP0                     ; insured person's info
+ D ID^IBCNSP01                      ; ins co ID numbers (IB*2*371)
+ D PLIM                             ; plan coverage limitations
+ D VER^IBCNSP01                     ; user/verifier/editor info
+ D CONTACT^IBCNSP0                  ; last insurance contact
+ D COMMENT                          ; comments - policy & plan
+ D RIDER^IBCNSP01                   ; policy rider info
+ ;
+ S VALMCNT=+$O(^TMP("IBCNSVP",$J,""),-1)
+ S IBLCNT=0
+ D POLICY^IBCNSP0,INS^IBCNSP0,SPON^IBCNSP0,LIMBLD^IBCNSC41(36,2,.IBLCNT)
+ D CONTACT^IBCNSP0,EFFECT,UR,EMP,VER^IBCNSP01,COMMENT,^IBCNSP01
+ Q
+ ;
 COMMENT ; -- Comment region
  N START,OFFSET,IBL,IBI
  S (START,IBL)=$O(^TMP("IBCNSVP",$J,""),-1)+1,OFFSET=2
  S IB1ST("COMMENT")=START
+ S START=49+$G(IBLCNT),OFFSET=2,IBL=0
+ I '$D(@VALMAR@(START-1)) D SET(START-1,OFFSET,"  ")
  D SET(START,OFFSET," Comment -- Patient Policy ",IORVON,IORVOFF)
+ S IBL=IBL+1
+ D SET(IBL,OFFSET,$S($P(IBCDFND1,U,8)="":"None",1:$P(IBCDFND1,U,8)))
+ S IBL=IBL+1
+ D SET(IBL,OFFSET," ")
+ S IBL=IBL+1
+ D SET(IBL,OFFSET," Comment -- Group Plan ",IORVON,IORVOFF)
+ D SET(START+1,OFFSET,$S($P(IBCDFND1,U,8)="":"None",1:$P(IBCDFND1,U,8)))
+ I '$D(@VALMAR@(START+2)) D SET(START+2,OFFSET,"  ")
+ D SET(START+3,OFFSET," Comment -- Group Plan ",IORVON,IORVOFF)
  S IBI=0 F  S IBI=$O(^IBA(355.3,+IBCPOL,11,IBI)) Q:IBI<1  D
+ . S IBL=IBL+1
+ . D SET(IBL,OFFSET,"  "_$E($G(^IBA(355.3,+IBCPOL,11,IBI,0)),1,80))
+ . Q
+ S IBL=IBL+1 D SET(IBL,OFFSET," ")
+ S IBL=IBL+1 D SET(IBL,OFFSET," ")
+ .S IBL=IBL+1
+ .D SET(START+IBL+3,OFFSET,"  "_$E($G(^IBA(355.3,+IBCPOL,11,IBI,0)),1,80))
+ S IBLCNT=$G(IBLCNT)+IBL+1 D SET(START+IBL+4,OFFSET,"  ")
+ Q
+ ;
 EFFECT ; -- Effective date region
  N START,OFFSET
  S START=16,OFFSET=45
+ S START=14,OFFSET=45
  D SET(START,OFFSET-4," Effective Dates & Source ",IORVON,IORVOFF)
  D SET(START+1,OFFSET," Effective Date: "_$$DAT1^IBOUTL($P(IBCDFND,U,8)))
 …
 UR ; -- UR of insurance region
  N START,OFFSET
  S START=16,OFFSET=2
+ S START=14,OFFSET=2
  D SET(START,OFFSET," Utilization Review Info ",IORVON,IORVOFF)
  D SET(START+1,OFFSET,"         Require UR: "_$$EXPAND^IBTRE(355.3,.05,$P(IBCPOLD,U,5)))
 …
 EMP ; -- Insurance Employer Region
  N OFFSET,START,IBADD
  S START=24,OFFSET=40
+ S START=19,OFFSET=40
  D SET(START,OFFSET," Subscriber's Employer Information ",IORVON,IORVOFF)
  D SET(START+1,OFFSET,"Emp Sponsored Plan: "_$S(+$P(IBCDFND2,U,10):"Yes",1:"No"))
 …
  D SET(START+4,OFFSET,"   Retirement Date: "_$$DAT1^IBOUTL($P(IBCDFND2,U,12)))
  D SET(START+5,OFFSET,"Claims to Employer: "_$S(+IBCDFND2:"Yes, Send to Employer",1:"No, Send to Insurance Company"))
+ ;I +IBCDFND2 W !!,"If ROI applies, make sure current consent is signed.",!! D PAUSE^VALM1
+ ;
  D SET(START+6,OFFSET,"            Street: "_$P(IBCDFND2,U,2)) S IBADD=1
 …
  D SET(START+7+IBADD,OFFSET,"             Phone: "_$P(IBCDFND2,U,8))
+ ;
- ; couple of blank lines to end this section
- D SET(START+8+IBADD,2," ")
- D SET(START+9+IBADD,2," ")
+ ;
 EMPQ Q
+ ;
-PLIM ; plan coverage limitations/plan limitation category display
- N START,END S START=$O(^TMP("IBCNSVP",$J,""),-1)+1
- S IB1ST("PLIM")=START
- D LIMBLD^IBCNSC41(START,2)
- S END=$O(^TMP("IBCNSVP",$J,""),-1)  ; last line constructed
- D SET(END+1,2," ")    ; 2 blank lines to end this section
- D SET(END+2,2," ")
-PLIMX ;
+ Q
+ ;
 HELP ; -- help code

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP0.m

-              r628
+              r636
 IBCNSP0 ;ALB/AAS - INSURANCE MANAGEMENT - EXPANDED POLICY ;05-MAR-1993
  ;;2.0;INTEGRATED BILLING;**28,43,52,85,93,103,137,229,251,363,371**;21-MAR-94;Build 57
+IBCNSP0 ;ALB/AAS - INSURANCE MANAGEMENT - EXPANDED POLICY  ;05-MAR-1993
+ ;;2.0;INTEGRATED BILLING;**28,43,52,85,93,103,137,229,251,363**;21-MAR-94;Build 35
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
 CONTACT ; -- Insurance Contact Information
  N OFFSET,START
+ ;
+ ; The start of this section is designed to start on the same line
+ ; as the User Information section (see VER^IBCNSP01).
+ ;
+ S START=$O(^TMP("IBCNSVP",$J,""),-1)-8
+ S IB1ST("CONTACT")=START
+ S OFFSET=42
+ S START=41+$G(IBLCNT),OFFSET=42
  N IBTRC,IBTRCD,IBTCOD
  S IBTCOD=$O(^IBE(356.11,"ACODE",85,0))
 …
  .S IBTRCD=$G(^IBT(356.2,+IBTRC,0))
+ ;
+ I '$D(@VALMAR@(START-1)) D SET(START-1,OFFSET,"  ")
  D SET(START,OFFSET," Insurance Contact (last) ",IORVON,IORVOFF)
  D SET(START+1,OFFSET," Person Contacted: "_$$EXPAND^IBTRE(356.2,.06,$P(IBTRCD,"^",6)))
 …
  D SET(START+4,OFFSET,"    Call Ref. No.: "_$$EXPAND^IBTRE(356.2,.09,$P(IBTRCD,"^",9)))
  D SET(START+5,OFFSET,"     Contact Date: "_$$EXPAND^IBTRE(356.2,.01,$P(IBTRCD,"^")))
- ; no blank lines here because the User Information section is on the
- ; left and it is bigger than this section
+ Q
+ ;
 …
  . D SET(START+IBX,OFFSET," Electronic Type: "_$$EXPAND^IBTRE(355.3,.15,$P(IBCPOLD,"^",15))) S IBX=IBX+1
  D SET(START+IBX,OFFSET,"  Plan Filing TF: "_$P(IBCPOLD,"^",13)) S IBX=IBX+1
+ ;
+ ; -- in case pointer is missing
  D SET(START+IBX,OFFSET,"      ePharmacy Plan ID: "_IBPLNID) S IBX=IBX+1
  D SET(START+IBX,OFFSET,"    ePharmacy Plan Name: "_IBPLNNM) S IBX=IBX+1
  D SET(START+IBX,OFFSET,"  ePharmacy Natl Status: "_IBPLNNA) S IBX=IBX+1
  D SET(START+IBX,OFFSET," ePharmacy Local Status: "_IBPLNLA) S IBX=IBX+1
+ ;
- ; -- in case pointer is missing
  I '$G(^IBA(355.3,+$P(IBCDFND,"^",18),0)) D
  .D SET(START+1,OFFSET,"Insurance Number: "_$P(IBCDFND,"^",2))
 …
+ ;
 SPON ; -- Sponsor (Insured Person) Region
  N IBC3,IBZIP,START,OFFSET,IBA,DA,DR,DIC,DIQ
  S IBC3=$G(^DPT(DFN,.312,IBCDFN,3))
+ N IBC3,IBSSN,IBZIP,START,OFFSET,IBA,DA,DR,DIC,DIQ
+ S IBC3=$G(^DPT(DFN,.312,IBCDFN,3)),IBSSN=$P(IBC3,"^",5)
  S DA=+$P(IBC3,"^",2),DR=.01,DIQ(0)="E",DIC="^DIC(23,",DIQ="IBA" D EN^DIQ1
  S START=$O(^TMP("IBCNSVP",$J,""),-1)+1,OFFSET=4
  D SET(START,OFFSET," Insured Person's Information (use Subscriber Update Action) ",IORVON,IORVOFF)
+ S START=30,OFFSET=4
+ D SET(START,OFFSET," Insured Person's Information (use Subscriber Update action) ",IORVON,IORVOFF)
  D SET(START+1,OFFSET,"    Insured's DOB: "_$$DAT3^IBOUTL($P(IBC3,"^")))
  D SET(START+2,OFFSET,"    Insured's Sex: "_$$EXTERNAL^DILFD(2.312,3.12,,$P(IBC3,U,12)))
  D SET(START+3,OFFSET," Insured's Branch: "_$G(IBA(23,DA,.01,"E")))
  D SET(START+4,OFFSET,"   Insured's Rank: "_$P(IBC3,"^",3))
+ D SET(START+2,OFFSET," Insured's Branch: "_$G(IBA(23,DA,.01,"E")))
+ D SET(START+3,OFFSET,"   Insured's Rank: "_$P(IBC3,"^",3))
+ D SET(START+4,OFFSET,"    Insured's SSN: "_$S(IBSSN]"":$E(IBSSN,1,3)_"-"_$E(IBSSN,4,5)_"-"_$E(IBSSN,6,9),1:""))
+ ;
  S OFFSET=43
 …
  D SET(START+4,OFFSET,"St/Zip: "_$P($G(^DIC(5,+$P(IBC3,"^",9),0)),"^",2)_"  "_IBZIP)
  D SET(START+5,OFFSET," Phone: "_$P(IBC3,"^",11))
+ ;
- ; blank lines at end of section
- D SET(START+6,2," ")
- D SET(START+7,2," ")
+ Q
+ ;
 …
  W:'(LINE#5) "."
+ Q
+ ;
 GPLAN(IBPLDA) ; get data from PLAN file (#366.03) related to the
  ; GROUP INSURANCE PLAN file (#355.3) and the INSURANCE COMPANY file (#36)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP01.m

-              r628
+              r636
 IBCNSP01 ;ALB/AAS - INSURANCE MANAGEMENT - EXPANDED POLICY  ;05-MAR-1993
  ;;2.0;INTEGRATED BILLING;**43,52,85,251,371,377**;21-MAR-94;Build 23
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+IBCNSP01 ;ALB/AAS - INSURANCE MANAGEMENT - EXPANDED POLICY  ; 05-MAR-1993
+ ;;2.0;INTEGRATED BILLING;**43,52,85,251**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
+ ;
 …
 SUBSC ; -- subscriber region
  N OFFSET,START
  S START=24,OFFSET=2
+ S START=19,OFFSET=2
  D SET^IBCNSP(START,OFFSET," Subscriber Information ",IORVON,IORVOFF)
  S Y=$P(IBCDFND,"^",6),C=$P(^DD(2.312,6,0),"^",2) D Y^DIQ
  D SET^IBCNSP(START+1,OFFSET," Whose Insurance: "_Y)
  D SET^IBCNSP(START+2,OFFSET," Subscriber Name: "_$P(IBCDFND,"^",17))
  S Y=$P(IBCDFND4,"^",3),C=$P(^DD(2.312,4.03,0),"^",2) D Y^DIQ
+ S Y=$P(IBCDFND,"^",16),C=$P(^DD(2.312,16,0),"^",2) D Y^DIQ
  D SET^IBCNSP(START+3,OFFSET,"    Relationship: "_Y)
  D SET^IBCNSP(START+4,OFFSET,"      Primary ID: "_$P(IBCDFND,"^",2))
+ D SET^IBCNSP(START+4,OFFSET,"Insurance Number: "_$P(IBCDFND,"^",2))
  S Y=$P(IBCDFND,"^",20),C=$P(^DD(2.312,.2,0),"^",2) D Y^DIQ
  D SET^IBCNSP(START+5,OFFSET,"Coord.  Benefits: "_Y)
 …
 VER ; -- Entered/Verfied Region
  N OFFSET,START
  S START=$O(^TMP("IBCNSVP",$J,""),-1)+1,OFFSET=2
  S IB1ST("VERIFY")=START
+ S START=41+$G(IBLCNT),OFFSET=2
+ I '$D(@VALMAR@(START-1)) D SET^IBCNSP(START-1,OFFSET,"  ")
  D SET^IBCNSP(START,OFFSET," User Information ",IORVON,IORVOFF)
+ I IBCDFND1="" D SET^IBCNSP(START+1,OFFSET,"No User Information") G VERQ
  D SET^IBCNSP(START+1,OFFSET,"      Entered By: "_$E($P($G(^VA(200,+$P(IBCDFND1,"^",2),0)),"^",1),1,20))
  D SET^IBCNSP(START+2,OFFSET,"      Entered On: "_$$DAT1^IBOUTL(+IBCDFND1))
 …
  D SET^IBCNSP(START+5,OFFSET," Last Updated By: "_$E($P($G(^VA(200,+$P(IBCDFND1,"^",6),0)),"^",1),1,20))
  D SET^IBCNSP(START+6,OFFSET," Last Updated On: "_$$DAT1^IBOUTL(+$P(IBCDFND1,"^",5)))
- D SET^IBCNSP(START+7,2," ")   ; 2 blank lines to end section
- D SET^IBCNSP(START+8,2," ")
 VERQ Q
+ ;
-ID ; Subscriber and patient primary and secondary ID's and qualifiers
- NEW START,OFFSET,IBL,G,PCE,QUAL,QUAL1
- S G=IBCDFND5
- S (START,IBL)=$O(^TMP("IBCNSVP",$J,""),-1)+1,OFFSET=2
- S IB1ST("ID")=START
- D SET^IBCNSP(START,OFFSET," Insurance Company ID Numbers (use Subscriber Update Action) ",IORVON,IORVOFF)
- S IBL=IBL+1
- D SET^IBCNSP(IBL,OFFSET,"  Subscriber Primary ID: "_$P(IBCDFND,U,2))
+ ;
- F PCE=3,5,7 D            ; subscriber secondary IDs
- . I $P(G,U,PCE)="" Q     ; no secondary ID#
- . S QUAL=$P(G,U,PCE-1)   ; internal qualifier code
- . S QUAL1=$S(QUAL="23":"Client#",QUAL="IG":"Ins. Policy#",QUAL="SY":"SSN",1:"Unknown")
- . S IBL=IBL+1
- . D SET^IBCNSP(IBL,OFFSET,"Subscriber Secondary ID: "_$P(G,U,PCE))
- . D SET^IBCNSP(IBL,52,"ID Qual: "_QUAL_" ("_QUAL1_")")
- . Q
+ ;
- ; patient=subscriber so skip over patient ID# display
- I +$P(IBCDFND,U,16)=1 G ID1
+ ;
- S IBL=IBL+1 D SET^IBCNSP(IBL,2," ")   ; blank line
- S IBL=IBL+1
- D SET^IBCNSP(IBL,OFFSET,"     Patient Primary ID: "_$P(G,U,1))
+ ;
- F PCE=9,11,13 D          ; patient secondary IDs
- . I $P(G,U,PCE)="" Q     ; no secondary ID#
- . S QUAL=$P(G,U,PCE-1)   ; internal qualifier code
- . S QUAL1=$S(QUAL="23":"Client#",QUAL="IG":"Ins. Policy#",QUAL="SY":"SSN",1:"Unknown")
- . S IBL=IBL+1
- . D SET^IBCNSP(IBL,OFFSET,"   Patient Secondary ID: "_$P(G,U,PCE))
- . D SET^IBCNSP(IBL,52,"ID Qual: "_QUAL_" ("_QUAL1_")")
- . Q
+ ;
-ID1 ; end of section - 2 blank lines
- S IBL=IBL+1 D SET^IBCNSP(IBL,2," ")
- S IBL=IBL+1 D SET^IBCNSP(IBL,2," ")
-IDQ ;
+ Q
+ ;
 RIDER ; -- Personal policy riders
  N OFFSET,START,IBI,IBL,IBPR,IBPRD
+ S START=$O(^TMP("IBCNSVP",$J,""),-1)+1,OFFSET=2,IBL=0
+ S START=53+$G(IBLCNT),OFFSET=2,IBL=0
+ I '$D(@VALMAR@(START-1)) D SET^IBCNSP(START-1,OFFSET,"  ")
  D SET^IBCNSP(START,OFFSET," Personal Riders ",IORVON,IORVOFF)
  S IBI="" F  S IBI=$O(^IBA(355.7,"APP",DFN,IBCDFN,IBI)) Q:'IBI  S IBPR=$O(^(IBI,0)),IBPRD=+$G(^IBA(355.7,IBPR,0)),IBL=IBL+1 D
+ . D SET^IBCNSP(START+IBL,OFFSET,"   Rider #"_IBL_": "_$$EXPAND^IBTRE(355.7,.01,IBPRD))
+ . Q
+ S IBL=IBL+1 D SET^IBCNSP(START+IBL,OFFSET," ")
+ S IBL=IBL+1 D SET^IBCNSP(START+IBL,OFFSET," ")
+ .D SET^IBCNSP(START+IBL,OFFSET,"   Rider #"_IBL_": "_$$EXPAND^IBTRE(355.7,.01,IBPRD))
+ S IBLCNT=$G(IBLCNT)+IBL
+ Q
+ ;
 AI ; -- Add ins. verification entry
  ;    called from ai^ibcnsp1
+ ;N X,Y,I,J,DA,DR,DIC,DIE,DR,DD,DO,VA,VAIN,VAERR,IBQUIT,IBXIFN,IBTRN,DUOUT,IBX,IBQUIT,DTOUT
+ ;Q:'$G(DFN)
+ ;Q:'$G(IBCDFN)  S IBQUIT=0
+ ;
  ; -- see if current inpatient

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP1.m

-              r628
+              r636
 IBCNSP1 ;ALB/AAS - INSURANCE MANAGEMENT - policy actions ;22-OCT-92
  ;;2.0;INTEGRATED BILLING;**6,28,40,43,52,85,103,361,371,377**;21-MAR-94;Build 23
+IBCNSP1 ;ALB/AAS - INSURANCE MANAGEMENT - policy actions ; 22-OCT-92
+ ;;2.0;INTEGRATED BILLING;**6,28,40,43,52,85,103,361**;21-MAR-94;Build 9
  ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;;ICR#5002 for read of ^DIE input template data
+ ;
 % G EN^IBCNSP
 …
  S DR="8;3;1.09//;3.04"
  D ^DIE K DIC,DIE,DA,DR
  D COMPPT^IBCNSP3(DFN,IBCDFN) I IBDIF D UPDATPT^IBCNSP3(DFN,IBCDFN),UPDCLM(DFN,IBCDFN),AFTER^IBCNSEVT,^IBCNSEVT,BLD^IBCNSP
+ D COMPPT^IBCNSP3(DFN,IBCDFN) I IBDIF D UPDATPT^IBCNSP3(DFN,IBCDFN),AFTER^IBCNSEVT,^IBCNSEVT,BLD^IBCNSP
  L -^DPT(DFN,.312,+$P($G(IBPPOL),"^",4))
 EDQ S VALMBCK="R" Q
 …
  D VARS^IBCNSP3
  L +^DPT(DFN,.312,+$P($G(IBPPOL),"^",4)):5 I '$T D LOCKED^IBTRCD1 G SUQ
+ ;
  D EDIT(DFN,IBCDFN)   ; IB*371 - edit pat ins 2.312 subfile fields
+ ;
+ S DR="6;S IBAD=X;K X I '$$VET^IBCNSU1() S Y=""@10"";17///^S X=$P(^DPT(DFN,0),U);16///^S X=""01"""
+ S DR=DR_";S Y=""@20"";@10;17;16//^S X=$S(IBAD=""s"":""02"",1:"""");@20;1;.2;4.01;4.02;3.01;3.12;3.02;3.03;3.05:3.11"
+ D ^DIE K DIC,DIE,DA,DR
  D COMPPT^IBCNSP3(DFN,IBCDFN)
  I IBDIF D UPDATPT^IBCNSP3(DFN,IBCDFN),BLD^IBCNSP
 …
  D AI^IBCNSP02
+ Q
+ ;
-PIDEF(IBREL,FLD,IBDFN,SPDEF) ; Function to return patient file defaults
- ; Called from input template IBCN PATIENT INSURANCE
- ; IBREL = value from 2.312,4.03 field (PT. RELATIONSHIP - HIPAA)
- ;   FLD = field# in file 2.312
- ; IBDFN = patient ien to file 2
- ; SPDEF = spouse default flag =1 if this field should be defaulted
- ;         when the spouse is the policy holder
+ ;
- ; The purpose is to provide a default value for the field when the
- ; patient and the ins. subscriber are the same.
+ ;
- NEW VAL
- S VAL=""
- I +$G(IBREL)'=1,+$G(IBREL)'=18 G PIDEFX     ; patient not the insured or spouse, get out
- I +$G(IBREL)=1,'$G(SPDEF) G PIDEFX          ; not a field for spouse default
- I '$G(FLD) G PIDEFX                         ; no field# passed in
- I '$G(IBDFN) G PIDEFX                       ; no patient passed in
+ ;
- ; Build the patient demographics area
- I '$D(^UTILITY("VADM",$J)) D
- . N VAHOW,DFN,VADM
- . S VAHOW=2,DFN=IBDFN D DEM^VADPT
- . Q
+ ;
- ; Build the patient address area
- I '$D(^UTILITY("VAPA",$J)) D
- . N VAHOW,DFN,VAPA
- . S VAHOW=2,DFN=IBDFN,VAPA("P")="" D ADD^VADPT
- . Q
+ ;
- I FLD=17 S VAL=$P($G(^UTILITY("VADM",$J,1)),U,1) G PIDEFX                          ; Name
- I FLD=3.01 S VAL=$$FMTE^XLFDT($P($G(^UTILITY("VADM",$J,3)),U,1),"5Z") G PIDEFX     ; Date of Birth
- I FLD=3.02 S VAL=$$EXTERNAL^DILFD(2,.325,,$P($G(^DPT(IBDFN,.32)),U,5)) G PIDEFX    ; Branch
- I FLD=3.05 S VAL=$P($G(^UTILITY("VADM",$J,2)),U,2) G PIDEFX                        ; SSN
- I FLD=3.06 S VAL=$P($G(^UTILITY("VAPA",$J,1)),U,1) G PIDEFX                        ; Street Address 1
- I FLD=3.07 S VAL=$P($G(^UTILITY("VAPA",$J,2)),U,1) G PIDEFX                        ; Street Address 2
- I FLD=3.08 S VAL=$P($G(^UTILITY("VAPA",$J,4)),U,1) G PIDEFX                        ; City
- I FLD=3.09 S VAL=$P($G(^UTILITY("VAPA",$J,5)),U,2) G PIDEFX                        ; State
- I FLD=3.1 S VAL=$P($G(^UTILITY("VAPA",$J,11)),U,2) G PIDEFX                        ; Zipcode
- I FLD=3.11 S VAL=$P($G(^UTILITY("VAPA",$J,8)),U,1) G PIDEFX                        ; Phone#
- I FLD=3.12 S VAL=$P($G(^UTILITY("VADM",$J,5)),U,2) G PIDEFX                        ; Sex
-PIDEFX ;
- Q VAL
+ ;
-ASK(QUES,DEFLT) ; Function to ask Yes/No Question
- ; Returns 1 (yes), 0 (no, up-arrow, or timeout)
- NEW X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
- S DIR(0)="Y",DIR("A")=$G(QUES)
- S DIR("B")=$S($G(DEFLT):"Yes",1:"No")
- W ! D ^DIR W:Y !
- I $D(DIRUT) S Y=0
-ASKX ;
- Q Y
+ ;
-EDIT(IBDFN,IBCDFN,IBQUIT) ; Main call to edit data in 2.312 pat ins subfile
- ;  IBDFN - patient DFN
- ; IBCDFN - ien for patient insurance policy in subfile 2.312
- ; IBQUIT - Output variable.  Pass by reference.  Will be set to 1 if
- ;          the user entered an up-arrow, timed-out, or deleted the
- ;          2.312 subfile entry by entering "@" at the .01 field
+ ;
- NEW DA,DR,DIE,IBZ,IBY,X,Y,DTOUT
- NEW IDS,SUB,PAT,PCE,SUB1,PAT1
- S DA(1)=+$G(IBDFN)    ; patient IEN
- S DA=+$G(IBCDFN)      ; patient insurance IEN
- I 'DA!'DA(1) G EDITX
- S DIE="^DPT("_IBDFN_",.312,"
+ ;
- ; Find the input template IEN for the [IBCN PATIENT INSURANCE] template
- S IBY=+$$FIND1^DIC(.402,,"X","IBCN PATIENT INSURANCE")
- I 'IBY G EDITX
+ ;
- ; Build the DR array/string - ICR# 5002
- M DR(1)=^DIE(IBY,"DR",2)
- S DR=$G(DR(1,2.312))
- I DR="" G EDITX
+ ;
- S $P(^DIE(IBY,0),U,7)=DT   ; see TEM+2^DIE  ICR# 5002
+ ;
- D ^DIE     ; edit subfile data
+ ;
- ; If the user entered an up-arrow, or timed-out, or deleted the entry,
- ; then set the output variable IBQUIT
- I $D(Y)!$D(DTOUT)!'$D(DA) S IBQUIT=1
+ ;
- F IBZ="VADM","VAPA" K ^UTILITY(IBZ,$J)    ; cleanup scratch global
+ ;
- D UPDCLM(IBDFN,IBCDFN)      ; update editable claims
+ ;
- ; Cleanup any problems in the secondary ID area
- S IDS=$G(^DPT(IBDFN,.312,IBCDFN,5))           ; whole 5 node
- S (SUB,PAT)=""
- F PCE=3:1:8 S $P(SUB,U,PCE)=$P(IDS,U,PCE-1)   ; subscriber sec ID/qual
- F PCE=3:1:8 S $P(PAT,U,PCE)=$P(IDS,U,PCE+5)   ; patient sec ID/qual
- ; SUB and PAT are 8-piece strings with pieces 1 and 2 being nil
- S SUB1=$$SCRUB^IBCEF21(SUB)                   ; scrub 8-piece string
- S PAT1=$$SCRUB^IBCEF21(PAT)                   ; scrub 8-piece string
- I SUB'=SUB1 S $P(^DPT(IBDFN,.312,IBCDFN,5),U,2,7)=$P(SUB1,U,3,8)
- I PAT'=PAT1 S $P(^DPT(IBDFN,.312,IBCDFN,5),U,8,13)=$P(PAT1,U,3,8)
+ ;
-EDITX ;
+ Q
+ ;
-UPDCLM(IBDFN,IBCDFN) ; Update the Insurance nodes of claims that are still editable
- NEW IBIFN
- S IBIFN=0 F  S IBIFN=$O(^DGCR(399,"C",IBDFN,IBIFN)) Q:'IBIFN  D UPDCLM^IBCNSP2(IBIFN,IBDFN,IBCDFN)
+ ;
-UPDCLMX ;
+ Q
+ ;
-PRELCNV(CODE,FLG) ; conversion between X12, NCPDP and VistA pt. relationship codes
- ; CODE - code for pt. relationship to convert
- ; FLG - 0 for X12 -> VistA conversion, 1 for VistA -> X12 conversion, 2 - for VistA -> NCPDP conversion
- ; returns converted code for pt. relationship, or null if no match found
- N I,RES,VSTR,X12STR
- S VSTR="01^02^03^08^11^15^32^33^34^35^36"
- S X12STR="18^01^19^20^39^41^32^33^29^53^G8"
- S RES=""
- I FLG=0 F I=1:1:11 S:$P(X12STR,U,I)=CODE RES=$P(VSTR,U,I) Q:RES'=""
- I FLG=1 F I=1:1:11 S:$P(VSTR,U,I)=CODE RES=$P(X12STR,U,I) Q:RES'=""
- I FLG=2,+CODE>0 S RES=$S(+CODE>3:"04",1:CODE)
- Q RES

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP2.m

-              r628
+              r636
 IBCNSP2 ;ALB/AAS - PATIENT INSURANCE INTERFACE FOR REGISTRATION ;21-JUNE-93
  ;;2.0;INTEGRATED BILLING;**6,28,75,82,155,371**;21-MAR-94;Build 57
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**6,28,75,82,155**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
 % ;
 …
+ ;
  I '$$ASKCOVD(DFN,.IBCOV,.IBCOVP) S IBQUIT=1 G REGQ
+ ; -- of covered by ins but none currently active so indicate
+ ;S IBCOV=$P($G(^DPT(DFN,.31)),"^",11)
+ ;I IBCOV="Y",'$$INSURED^IBCNS1(DFN) W !!,"Covered By Health Insurance indicates 'YES' but none currently Active.",!,"Please Review!",!!
+ ;
+ ;; -- ask if covered by insuracnce
+ ;S DIE="^DPT(",DR=".3192",DA=DFN D ^DIE K DIC,DIE,DA,DR
+ ;S IBCOVP=$P($G(^DPT(DFN,.31)),"^",11)
+ ;I $D(Y)!($D(DTOUT)) S IBQUIT=1 G REGQ
+ ;I $P($G(^DPT(DFN,.31)),"^",11)'="Y",'$$INSURED^IBCNS1(DFN) S IBQUIT=1 G REGQ
+ ;
 R1 S (IBNEW,IBNEWP,IBQUIT)=0
 …
  ; -- edit patient ins. data
  S IBREG=1 G:$G(IBQUIT) REGQ
  D PAT^IBCNSEH,PATPOL^IBCNSM32(IBCDFN),UPDCLM(+$G(IBIFN),DFN,IBCDFN)
+ D PAT^IBCNSEH,PATPOL^IBCNSM32(IBCDFN)
+ ;
  ; -- edit policy specific data if new or have key
 …
+ ;
 FEE ; -- fee entry point to add patient insurance.
+ ;N IBFEE S IBFEE=1 D REG
  D FEE^IBCNBME(DFN)
+ Q
 …
  I 'IBMCR,$$WNRBILL^IBEFUNC(IBIFN) S DGRVRCAL=1
  K IBCNRTN
+ Q
+ ;
-UPDCLM(IBIFN,DFN,IBCDFN) ; Update the claim's insurance nodes when edits are made
- ;   to the patient insurance file.
- ;  This procedure is called when a claim is being edited from IB billing
- ;  screen#3 and also when the patient insurance is being edited directly.
+ ;
- I '$G(IBIFN)!'$G(DFN)!'$G(IBCDFN) Q         ; missing something
- I $P($G(^DGCR(399,IBIFN,0)),U,2)'=DFN Q     ; mismatch of claim and DFN
- I $P($G(^DGCR(399,IBIFN,0)),U,13)'=1 Q      ; claim not editable
- I '$D(^DPT(DFN,.312,IBCDFN,0)) Q            ; missing pat ins data
- NEW X,Z,NODE
- S X=IBCDFN
- F Z=1:1:3 I $P($G(^DGCR(399,IBIFN,"M")),U,11+Z)=IBCDFN D  Q
- . S NODE="I"_Z
- . D IX^IBCNS2(IBIFN,NODE)
- . Q
+ Q
+ ;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP3.m

-              r628
+              r636
 IBCNSP3 ;ALB/AAS - INSURANCE MANAGEMENT EDIT ;06-JUL-93
  ;;2.0;INTEGRATED BILLING;**28,52,85,251,371**;21-MAR-94;Build 57
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+IBCNSP3 ;ALB/AAS - INSURANCE MANAGEMENT EDIT ; 06-JUL-93
+ ;;2.0;INTEGRATED BILLING;**28,52,85,251**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
 % G ^IBCNSM4
 …
  S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,3)=$G(^DPT(DFN,.312,+DA,3))
  S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,4)=$G(^DPT(DFN,.312,+DA,4))
- S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,5)=$G(^DPT(DFN,.312,+DA,5))
+ Q
+ ;
 …
  I $G(^DPT(DFN,.312,+DA,3))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,3)) S IBDIF=1 G COMPPTQ
  I $G(^DPT(DFN,.312,+DA,4))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,4)) S IBDIF=1 G COMPPTQ
- I $G(^DPT(DFN,.312,+DA,5))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,5)) S IBDIF=1 G COMPPTQ
+ ;
 COMPPTQ I IBDIF D:'$D(IBCOVP) COVERED^IBCNSM31(DFN,$P($G(^DPT(DFN,.31)),"^",11))

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSU.m

-              r628
+              r636
 IBCNSU ;ALB/AAS - INSURANCE UTILITY ROUTINE ;19-MAY-93
  ;;2.0;INTEGRATED BILLING;**28,103,371**; 21-MAR-94;Build 57
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+IBCNSU ;ALB/AAS - INSURANCE UTILITY ROUTINE ; 19-MAY-93
+ ;;2.0;INTEGRATED BILLING;**28,103**; 21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
 AB(IBCPOL,IBYR,IBASK) ; -- Return entry in Annual Benefits file
 …
+ ;
 DELPQ Q X
+ ;
-DUPADDRL(DATA,IBCNS,FLD1,FLD2) ; Insurance address lines can not be duplicated
- ; DATA - Value being compared
- ; FLD1 - First field to check against
- ; FLD2 - Second field to check against (OPTIONAL)
+ ;
- ; Returns 1 if this field is a duplicate of another field.
+ ;
- N Z1,Z2
- Q:$G(DATA)="" 0  ; should not happen because this is invoked as an input transform
- Q:'$G(IBCNS) 1  ; stop from editing through fileman
- S DATA=$$UP^XLFSTR($G(DATA)),DATA=$$TRIM^XLFSTR(DATA)
- S Z1=$$GET1^DIQ(36,+$G(IBCNS),+$G(FLD1),"I")
- S Z1=$$UP^XLFSTR(Z1),Z1=$$TRIM^XLFSTR(Z1)
- S Z2=$$GET1^DIQ(36,+$G(IBCNS),+$G(FLD2),"I")
- S Z2=$$UP^XLFSTR(Z2),Z2=$$TRIM^XLFSTR(Z2)
- I DATA=Z1 D CLEAN^DILF Q 1
- I DATA=Z2 D CLEAN^DILF Q 1
- D CLEAN^DILF
- Q 0
+ ;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSU1.m

-              r628
+              r636
 IBCNSU1 ;ALB/AAS - INSURANCE UTILITY ROUTINE ;19-MAY-93
  ;;2.0;INTEGRATED BILLING;**103,133,244,371**;21-MAR-94;Build 57
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+IBCNSU1 ;ALB/AAS - INSURANCE UTILITY ROUTINE ; 19-MAY-93
+ ;;2.0;INTEGRATED BILLING;**103,133,244**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
 RCHK(X) ; -- Input transform for different revenue codes in file 36
 …
+ ;
  N IBY,IB0 S IBY=0
- G VETQ    ; IB*2*371 - Allow edits to the patient name in all cases
  S IB0=$G(^DPT(+$G(DA(1)),.312,+$G(DA),0))
  I $P(IB0,"^",6)'="v" G VETQ
 …
  S X1=$TR(X,CHAR,"") I X1?9N,X1=L S X=X1
+ ;
+ ; - if "SS" is entered, and the policy belongs to the patient,
+ ;   convert that string to the patient's SSN
+ I R=1,X="SS" W "  ",L S X=L
+ ;
  K:$L(X)>20!($L(X)<3) X
+ Q
 …
  S:IBY="" IBY=-1
 HICNQ Q IBY
+ ;
-CHKQUAL(DFN,IEN,QUAL,PC1,PC2) ; check for duplicate qualifiers for patient
- ; and subscriber secondary ID's.  All parameters required.
+ ;
- ;   DFN - internal patient#
- ;   IEN - ien of 2.312 subfile
- ;  QUAL - passed in response of the user (this is what is being
- ;         checked to see if it is valid)
- ;   PC1 - this is the piece# for one of the other qualifiers
- ;   PC2 - this is the piece# for one of the other qualifiers
+ ;
- ; Function returns 1 if the entered qualifier is OK.
- ; Function returns 0 if the entered qualifier is not OK.  It is either
- ;                    a duplicate or is otherwise invalid.
+ ;
- NEW OK,DATA,INS
- S OK=1
- I $G(QUAL)="" G CHKQUALX
- S DATA=$G(^DPT(+$G(DFN),.312,+$G(IEN),5))
- I $G(QUAL)=$P(DATA,U,+$G(PC1)) D CQ1 G CHKQUALX   ; duplicate
- I $G(QUAL)=$P(DATA,U,+$G(PC2)) D CQ1 G CHKQUALX   ; duplicate
+ ;
- ; prevent the SSN qualifier when Medicare is the payer
- S INS=+$G(^DPT(+$G(DFN),.312,+$G(IEN),0))
- I $G(QUAL)="SY",$$MCRWNR^IBEFUNC(INS) D CQ2 G CHKQUALX
+ ;
-CHKQUALX ;
- Q OK
+ ;
-CQ1 ; specific error message#1
- S OK=0
- D EN^DDIOL("You cannot use the same qualifier more than once.",,"!!")
- D EN^DDIOL("",,"!!?5")
+ Q
+ ;
-CQ2 ; specific error message#2
- S OK=0
- D EN^DDIOL("You cannot use qualifier 'SY' for Medicare.",,"!!")
- D EN^DDIOL("",,"!!?5")
+ Q
+ ;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBC.m

-              r628
+              r636
 IBCRBC ;ALB/ARH - RATES: BILL CALCULATION OF CHARGES ; 22-MAY-1996
  ;;2.0;INTEGRATED BILLING;**52,80,106,51,137,245,370**;21-MAR-94;Build 5
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**52,80,106,51,137,245**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
  ; Variable DGPTUPDT may be defined on entry/exit for inpt bills so the PTF will only be updated once per session
 …
+ ;
  I '$D(^TMP($J,"IBCRCC")) G END
+ ;
+ D MULTCPT^IBCRBCA1 ; adjust charges for Multiple Surgical Procedure Discount
+ D PSB^IBCRBCA2 ;     adjust charges for Primary/Secondary Bundling
+ D MODADJ^IBCRBCA3 ;  adjust charges for Modifier Adjustment
+ ;
  D SORTCI^IBCRBC3 I '$D(^TMP($J,"IBCRCS")) G END
 …
  ;                        21 procedures associated clinic
  ;                        22 procedures Outpatient Encounter, pointer to #409.68
- ;                        23 list of all the procedures modifiers, separated by ','
+ ;
  ;  ^TMP($J,"IBCRCC",X,"CC",x) = comments explaining charge adjustements

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBC1.m

-              r628
+              r636
 IBCRBC1 ;ALB/ARH - RATES: BILL CALCULATION BILLABLE EVENTS ; 22 MAY 96
  ;;2.0;INTEGRATED BILLING;**52,80,106,138,51,148,245,270,370**;21-MAR-94;Build 5
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**52,80,106,138,51,148,245,270**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
  ; For each type of Billable Event, search for items on the bill and calculate the charges
 …
+ ;
  N IBX,IBBLITEM,IBCHGMTH,IBBR,IBBDIV,IBIDRC,IBCPTARR,IBCPT,IBCPTFN,IBEVDT,IBMOD,IBDIV,IBTYPE,IBCMPNT
  N IBPPRV,IBBS,IBCLIN,IBOE,IBSAVE,IBUNIT,IBCPTRX,IBMODS I '$G(IBIFN)!'$G(CS) Q
+ N IBPPRV,IBBS,IBCLIN,IBOE,IBSAVE,IBUNIT,IBCPTRX I '$G(IBIFN)!'$G(CS) Q
+ ;
  D CPT^IBCRBG1(IBIFN,.IBCPTARR) Q:'IBCPTARR
 …
  . S IBCPT=0 F  S IBCPT=$O(IBCPTARR(IBCPT)) Q:'IBCPT  D
  .. S IBCPTFN=0 F  S IBCPTFN=$O(IBCPTARR(IBCPT,IBCPTFN)) Q:'IBCPTFN  D
  ... S IBX=IBCPTARR(IBCPT,IBCPTFN),IBEVDT=$P(IBX,U,1),(IBMOD,IBMODS)=$P(IBX,U,2)
+ ... S IBX=IBCPTARR(IBCPT,IBCPTFN),IBEVDT=$P(IBX,U,1),IBMOD=$P(IBX,U,2)
  ... S IBDIV=$P(IBX,U,3),IBPPRV=$P(IBX,U,4),IBCLIN=$P(IBX,U,5),IBOE=$P(IBX,U,6)
  ... ;
 …
  ... I +IBMOD S IBMOD=$P($$CPTMOD^IBCRCU1(CS,IBCPT,IBMOD,IBEVDT),",",1) ; check CPT-MODs for billable combination
  ... ;
  ... S IBSAVE="1^"_IBCPT_U_IBDIV_U_IBTYPE_U_IBCPTFN_U_IBCMPNT_U_IBBS_U_IBPPRV_U_IBCLIN_U_IBOE_U_IBMODS
+ ... S IBSAVE="1^"_IBCPT_U_IBDIV_U_IBTYPE_U_IBCPTFN_U_IBCMPNT_U_IBBS_U_IBPPRV_U_IBCLIN_U_IBOE
  ... D BITMCHG^IBCRBC2(RS,CS,IBCPT,IBEVDT,IBUNIT,IBMOD,"",IBIDRC,IBSAVE)
  K ^TMP($J,"IBCRC-INDT")

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBC2.m

-              r628
+              r636
 IBCRBC2 ;ALB/ARH - RATES: BILL CALCULATION OF ITEM CHARGE ; 22-MAY-1996
  ;;2.0;INTEGRATED BILLING;**52,106,138,148,245,370**;21-MAR-94;Build 5
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**52,106,138,148,245**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
  ; Input:  RS     - rate schedule necessary to calculated modified charges
 …
  ;                  CLINIC - procedures associated clinic
  ;                  IBOE   - Outpatient Encounter, pointer to #408.69
- ;                  MODS   - list of all modifiers define for the procedure, separated by ','
+ ;
  ; Total charge is calculated:  X = UNITS * UNIT CHARGE of the item         (per unit charge (un-adjusted))
 …
 BITMCHG(RS,CS,ITEM,EVDT,UNITS,MOD,INSRC,IDFRC,SAVE) ; get bill charges for a specific item, rate schedule and charge set and date set into temp array
+ ;
  N IBCS0,IBDRVCD,IBBS,IBCHGARR,IBI,IBCNT,IBLN,IBCI,IBRVCD,IBPPRV,IBCHRG,IBTCHRG,IBRCHRG,IBPCHRG,IBACHRG
  N IBMCHRG,IBMODS,IBBASE,IBCOM I '$G(ITEM)!'$G(CS)!'$G(UNITS) Q
+ N IBCS0,IBDRVCD,IBBS,IBCHGARR,IBI,IBCNT,IBLN,IBCI,IBRVCD,IBPPRV,IBCHRG,IBTCHRG,IBRCHRG,IBPCHRG,IBACHRG,IBBASE,IBCOM
+ I '$G(ITEM)!'$G(CS)!'$G(UNITS) Q
+ ;
  S RS=$G(RS),EVDT=$S(+$G(EVDT):+EVDT\1,1:DT),MOD=$G(MOD),INSRC=$G(INSRC),IDFRC=$G(IDFRC),SAVE=$G(SAVE)
  S IBCS0=$G(^IBE(363.1,+CS,0)),IBDRVCD=$P(IBCS0,U,5),IBPPRV=$P(SAVE,U,8),IBMODS=$P(SAVE,U,11)
+ S IBCS0=$G(^IBE(363.1,+CS,0)),IBDRVCD=$P(IBCS0,U,5),IBPPRV=$P(SAVE,U,8)
  S IBBS=+ITEM I $P($G(^IBE(363.3,+$P(IBCS0,U,2),0)),U,4)'=1 S IBBS=$P(SAVE,U,7) I 'IBBS S IBBS=$P(IBCS0,U,6)
  I 'IBBS Q
 …
  . S IBCHRG=IBCHRG+IBBASE
  . S IBPCHRG=IBCHRG I +IBPPRV S IBPCHRG=$$PRVCHG^IBCRCC(CS,IBCHRG,IBPPRV,EVDT,ITEM)
+ . S IBMCHRG=+IBPCHRG I +IBMODS S IBMCHRG=$$MODCHG^IBCRCC(CS,IBPCHRG,IBMODS)
+ . S (IBCHRG,IBTCHRG)=+IBMCHRG
+ . S (IBCHRG,IBTCHRG)=+IBPCHRG
  . S IBACHRG=IBTCHRG I +RS,+IBTCHRG S IBRCHRG=$$RATECHG^IBCRCC(RS,IBTCHRG,EVDT),IBACHRG=+IBRCHRG
  . ;
 …
  . I (UNITS>1)!(+IBBASE) S IBCOM=$$COMMUB(CS,UNITS,IBBASE) I IBCOM'="" D COMMENT(IBCNT,IBCOM)
  . I $P(IBPCHRG,U,2)'="" S IBCOM=$P(IBPCHRG,U,2) I IBCOM'="" D COMMENT(IBCNT,IBCOM)
- . I $P(IBMCHRG,U,2)'="" S IBCOM=$P(IBMCHRG,U,2) I IBCOM'="" D COMMENT(IBCNT,IBCOM)
  . I $P(IBRCHRG,U,2)'="" S IBCOM=$P(IBRCHRG,U,2) I IBCOM'="" D COMMENT(IBCNT,IBCOM)
+ Q

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBG.m

-              r628
+              r636
 IBCRBG ;ALB/ARH - RATES: BILL SOURCE EVENTS (INPT) ; 21 MAY 96
  ;;2.0;INTEGRATED BILLING;**52,80,106,51,142,159,210,245,382,389**;21-MAR-94;Build 6
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**52,80,106,51,142,159,210,245**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
 INPTPTF(IBIFN,CS) ; search PTF record for billable bedsections, transfer DRGs, and length of stay
  ; - screens out days for pass, leave and SC treatment
  ; - adds charges for only one BS if the ins company does not allow multiple bedsections per bill (36,.06)
  ; Output: ^TMP($J,"IBCRC-INDT", BILLABLE DATE) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIV ^ SPECIALTY ^ MOVE #
+ ; Output:  ^TMP($J,"IBCRC-INDT", BILLABLE DATE) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIVISION ^ SPECIALTY
+ ;
  N IB0,DFN,PTF,IBU,IBBDT,IBEDT,IBTF,IBADM,IBX,IBINSMBS
 …
  D PTF(PTF) ; get movements and bedsections
  D PTFDV(PTF) ; reset movements and bedsections for ward/division
- D PTFFY(PTF,IBBDT,IBEDT) ; reset movements for FY DRG change
+ ;
  D BSLOS(IBBDT,IBEDT,IBTF,IBADM,IBINSMBS) ; calculate days in bedsections within timeframe of the bill
 …
 PTF(PTF) ; find all movements in PTF for the admission by date and billing bedsection (501 movement)
  ; the movement date is the date the patient left the bedsection
  ; Output: ^TMP($J,"IBCRC-PTF", MOVE DT/TM)=MOVE DT/TM ^ BILL BED ^ SC FLAG ^ TRANSFER DRG ^ ^ SPECIALTY ^ MOVE #
+ ; Output:  ^TMP($J,"IBCRC-PTF", MOVE DT/TM)=MOVE DT/TM ^ BILL BEDSECTION ^ SC FLAG ^ TRANSFER DRG ^ ^ SPECIALTY
+ ;
  N IBMOVE,IBMVLN,IBBILLBS,IBENDDT,IBMSC,IBMDRG S PTF=+$G(PTF)
 …
  . S IBMSC="" I +$P(IBMVLN,U,18)=1 S IBMSC=1 ;                          sc movement
  . S IBMDRG=$$MVDRG(PTF,IBMOVE) ;                                       movement DRG
  . S ^TMP($J,"IBCRC-PTF",IBENDDT)=IBENDDT_U_IBBILLBS_U_IBMSC_U_IBMDRG_U_U_+$P(IBMVLN,U,2)_U_IBMOVE
+ . S ^TMP($J,"IBCRC-PTF",IBENDDT)=IBENDDT_U_IBBILLBS_U_IBMSC_U_IBMDRG_U_U_+$P(IBMVLN,U,2)
+ Q
+ ;
 …
  ; the movement date is the date the patient left the bedsection, so admission date is not in PTF array
+ ;
  ; Input:  ^TMP($J,"IBCRC-PTF", MOVE DT/TM) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIV ^ SPECIALTY ^ MOVE #
  ; Output: ^TMP($J,"IBCRC-INDT", BILLABLE DATE) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIV ^ SPECIALTY ^ MOVE #
+ ; Input:   ^TMP($J,"IBCRC-PTF", MOVE DT/TM) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIVISION ^ SPECIALTY
+ ; Output:  ^TMP($J,"IBCRC-INDT", BILLABLE DATE) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIVISION ^ SPECIALTY
+ ;
  N IBSBDT,IBSEDT,IBS,IBLASTDT,IBX
 …
 PTFDV(PTF) ; find all ward/location transfers in PTF for the patient to determine the site/division the patient was in
  ; the division of the ward will be added to the PTF bedsection movements
  ; Input:  ^TMP($J,"IBCRC-PTF", move dt/tm) = move dt/tm ^ bill bs ^ sc flag ^ move drg ^ ^ specialty ^ move #
  ; Output: ^TMP($J,"IBCRC-PTF", move dt/tm) = move dt/tm ^ bill bs ^ sc flag ^ move drg ^ WARD DIV ^ spec ^ move#
+ ; Input:   ^TMP($J,"IBCRC-PTF", move dt/tm) = move dt/tm ^ bill bs ^ sc flag ^ move drg ^^ specialty
+ ; Output:  ^TMP($J,"IBCRC-PTF", move dt/tm) = move dt/tm ^ bill bs ^ sc flag ^ move drg ^ WARD DIV ^ specialty
  ;          ^TMP($J,"IBCRC-DIV", TRANSFER DATE/TIME) = WARD DIVISION
  N IBTRNSF,IBTRLN,IBENDDT,IBTRDV,IBMVDT,IBTRDT
 …
+ Q
+ ;
+PTFFY(PTF,BEGDT,ENDDT) ; add movement for FY (10/1) if date range covers FY and DRG changes
+ ; the DRG may change on FY so check and if necessary add movement for pre-FY with old DRG
+ ; Input:  ^TMP($J,"IBCRC-PTF", move dt/tm) = move dt/tm ^ bill bs ^ sc flag ^ move drg ^ ^ specialty ^ move #
+ ; Output: ^TMP($J,"IBCRC-PTF", move dt/tm) = move dt/tm ^ bill bs ^ sc flag ^ MOVE DRG ^ ward div ^ spec ^ move#
+ N IBBEGDT,IBENDDT,IBYRB,IBYRE,IBYR,IBFY,IBMVLN,IBMVDRG,IBMOVE,IBFYDRG Q:'$G(PTF)
+ Q:'$G(BEGDT)  S IBFY=$E(BEGDT,1,3)_"1001"
+ ;
+ S IBBEGDT=BEGDT,IBENDDT=BEGDT\1 F  S IBENDDT=$O(^TMP($J,"IBCRC-PTF",IBENDDT)) Q:'IBENDDT  D  S IBBEGDT=IBENDDT
+ . S IBYRB=$E(IBBEGDT,1,3),IBYRE=$E(IBENDDT,1,3) I (IBYRE-IBYRB)>10 Q
+ . F IBYR=IBYRB:1:IBYRE S IBFY=IBYR_"1001" I IBBEGDT<IBFY,IBENDDT>IBFY D
+ .. S IBMVLN=$G(^TMP($J,"IBCRC-PTF",IBENDDT)),IBMVDRG=$P(IBMVLN,U,4),IBMOVE=$P(IBMVLN,U,7)
+ .. S IBFYDRG=$$MVDRG(PTF,IBMOVE,IBYR_"0930")
+ .. I IBMVDRG'=IBFYDRG S $P(IBMVLN,U,4)=IBFYDRG S ^TMP($J,"IBCRC-PTF",IBFY)=IBMVLN
+ Q
+ ;
+MVDRG(PTF,M,CDATE) ; Return the DRG for a specific PTF Movememt (M=move ifn)
+ ; CDATE is optional, used if need to calculate DRG for some day within the move, not at the end date
+MVDRG(PTF,M) ; Return the DRG for a specific PTF Movememt (M=move ifn)
  N DPT0,PTF0,PTFM0,PTF70,IBBEG,IBEND,IBDSST,IBDX,IBPRC0,IBPRC,IBDRG,IBI,IBJ,IBP
  N SEX,AGE,ICDDX,ICDPRC,ICDEXP,ICDDMS,ICDTRS,ICDDRG,ICDMDC,ICDRTC,ICDDATE
 …
  .. F IBI=5:1:9 S IBPRC=$P(IBPRC0,U,IBI) I +IBPRC,($$ICD0^IBACSV(+IBPRC)'="") S IBJ=IBJ+1,ICDPRC(IBJ)=+IBPRC
+ ;
  S ICDDATE=$S(+$G(CDATE):CDATE,+$P(PTFM0,U,10):+$P(PTFM0,U,10),1:DT) ; date for the DRG Grouper versioning
+ S ICDDATE=$P(PTFM0,U,10) ; use the movement date for the DRG Grouper versioning
  D ^ICDDRG S IBDRG=$G(ICDDRG)
+ ;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBH1.m

-              r628
+              r636
 IBCRBH1 ;ALB/ARH - RATES: BILL HELP DISPLAYS - CHARGES ; 10-OCT-1998
  ;;2.0;INTEGRATED BILLING;**106,245,370**;21-MAR-94;Build 5
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**106,245**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
 DISPCHG(IBIFN) ; display a bills items and their charges, display only, does not change the charges on the bill
 …
  .. I IBBEVNT["PROSTHETICS" D PI^IBCRBC1(IBIFN,IBRS,IBCS)
  .. I IBBEVNT["PROCEDURE" D CPT^IBCRBC1(IBIFN,IBRS,IBCS)
+ ;
+ I '$D(^TMP($J,"IBCRCC")) G END
+ ;
+ D MULTCPT^IBCRBCA1
+ D PSB^IBCRBCA2
+ D MODADJ^IBCRBCA3
+ ;
 END Q

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRCC.m

-              r628
+              r636
 IBCRCC ;ALB/ARH - RATES: CALCULATION OF ITEM CHARGE ;22-MAY-1996
  ;;2.0;INTEGRATED BILLING;**52,80,106,138,245,223,309,347,370**;21-MAR-94;Build 5
+ ;;2.0;INTEGRATED BILLING;**52,80,106,138,245,223,309,347**;21-MAR-94;Build 24
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
  Q IBX_IBPDTY
+ ;
-MODCHG(CS,CHG,MODS) ; return adjusted amount due to RC modifier adjustment
- ; straight adjustment for RC Physician charges by modifier, if no modifier adjustment returns original amount
- ; Input:  Charge Set, Procedure Charge, Modifiers - list with modifier IEN's separated by ','
- ; Output: discounted amount ^ comment (if discounted) ^ percent discount
+ ;
- N IBCS0,IBBR0,IBMOD,IBMODS,IBMODE,IBDSCNT,IBPDTY,IBI,IBX,IBY
- S CHG=+$G(CHG),MODS=$G(MODS),(IBBR0,IBPDTY,IBMODS)="",IBDSCNT=1,IBX=+CHG
- I +$G(CS) S IBCS0=$G(^IBE(363.1,+CS,0)),IBBR0=$G(^IBE(363.3,+$P(IBCS0,U,2),0))
- I $P(IBBR0,U,1)'["RC PHYSICIAN" S MODS="" ; professional charge only
- I $P(IBBR0,U,4)'=2 S MODS="" ; CPT item only
- I 'CHG S MODS=""
+ ;
- I +MODS F IBI=1:1 S IBMOD=$P(MODS,",",IBI) Q:'IBMOD  S IBY=0 D
- . I IBMOD=3 S IBMODE=22,IBY=1.2,IBX=IBX*IBY ; modifier 22 at 120% adjustment
- . I IBMOD=10 S IBMODE=50,IBY=1.54,IBX=IBX*IBY ; modifier 50 at 154% adjustment
- . I +IBY S IBMODS=IBMODS_$S(IBMODS="":"",1:",")_IBMODE,IBDSCNT=IBDSCNT*IBY ; allow for multiple discounts
- I IBMODS'="" S IBPDTY=U_"Modifier "_IBMODS_" Adjustment "_(IBDSCNT*100)_"% of "_$J(CHG,0,2)_U_+IBDSCNT
- Q IBX_IBPDTY
+ ;
 HRUNIT(HRS) ; returns Hour Units based on the Hours passed in
  ; Hour Units are the hours rounded to the nearest whole hour (less than 30 minutes is 0 units)
 …
+ ;
 MNUNIT(MNS) ; return Minute Units based on the Minutes passed in
  ; Minute Units are 15 minute intervals, rounded up after any minutes
  N IBX S IBX=0 I +$G(MNS) S IBX=(MNS\15) S:+(MNS#15) IBX=IBX+1 I 'IBX S IBX=1
+ ; Minute Units are 15 minute intervals, rounded down for less than 5 minutes
+ N IBX S IBX=0 I +$G(MNS) S IBX=(MNS\15) S:(MNS#15)>4 IBX=IBX+1 I 'IBX S IBX=1
  Q IBX

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRHBRV.m

-              r628
+              r636
 IBCRHBRV ;ALB/ARH - RATES: UPLOAD (RC) VERSION FUNCTIONS ; 14-FEB-01
  ;;2.0;INTEGRATED BILLING;**148,169,245,270,285,298,325,334,355,360,365,382,390**;21-MAR-94;Build 2
+ ;;2.0;INTEGRATED BILLING;**148,169,245,270,285,298,325,334,355,360,365**;21-MAR-94;Build 2
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
  ; RC functions related to Version.  Update VLIST with new versions.  Update FTYPE if new types of files.
+ ; RC functions related to Version, most have to be updated when a new version is to be exported
+ ;
 SELVERS() ; get version to upload from user
+ N DIR,DIRUT,DTOUT,DUOUT,IBVLIST,IBQUIT,IBVERS,IBI,IBJ,IBX,X,Y
+ ;
+ S IBVLIST=$$VERSTR(),IBQUIT=0,IBVERS=0
+ ;
+ W !!,"Select the version of Reasonable Charges to upload."
+ S DIR("?",1)="Enter the code from the list corresponding to the version of Reasonable Charges"
+ S DIR("?",2)="to upload.  There are no version 1.3, 2.2, or 2.10 (ten) RC charges." S DIR("?",3)=" "
+ S DIR("?",4)="Versions: "_IBVLIST S DIR("?",5)=" " S DIR("?")="Enter version number to upload."
+ ;
+ F IBI=1:1 D  I +IBQUIT Q
+ . W !!,?5,"Select one of the following:",!
+ . F IBJ=1:1 S IBX=$P(IBVLIST,",",IBJ) Q:'IBX  W !,?10,IBX,?20,"Reasonable Charges version ",IBX
+ . ;
+ . W ! S DIR("A")="Enter Version" S DIR(0)="FO^1:5" D ^DIR I $D(DIRUT) S IBQUIT=1
+ . I Y>0,(","_IBVLIST_",")[(","_Y_",") S IBVERS=Y,IBQUIT=1 W "  Reasonable Charges version ",IBVERS
+ ;
+ Q IBVERS
+ N DIR,DIRUT,DTOUT,DUOUT,X,Y,IB,IBV,IBVP,IBX
+ S IBV="1.0^1.1^1.2^1.4^2.0^2.1^2.3^2.4^2.5^2.6^2.7^2.8^2.9" ; List of valid version numbers
+ S IBX=0
+ W !!,"Select the version of Reasonable Charges to upload.",!
+ S DIR("?")="Enter a code from the list corresponding to the version of Reasonable Charges to upload.  There was no version 1.3 nor 2.2 of Reasonable Charges."
+ S DIR(0)="SO^"
+ F IB=1:1:$L(IBV,U) S IBVP=$P(IBV,U,IB),DIR(0)=DIR(0)_+IBVP_":Reasonable Charges version "_IBVP_";"
+ D ^DIR K DIR S:$L(Y)=1 Y=Y_".0" S IBX=+$S(IBV[Y:Y,1:0)
+ Q IBX
+ ;
 VERSION() ; return currently loaded version of RC files (1, 1.1, ...)
 …
+ ;
 VERSDT(VERS) ; return Effective Date of a version of RC files, either version passed in or currently loaded version
  N IBI,LINE,IBX S IBX="" S VERS=+$G(VERS) I 'VERS S VERS=$$VERSION
  I +VERS F IBI=1:1 S LINE=$P($T(VLIST+IBI),";;",2,99) Q:'LINE  I VERS=+LINE S IBX=$P(LINE,U,3)
+ N IBX S:'$G(VERS) VERS=$$VERSION
+ S IBX=$S(VERS=1:2990901,VERS=1.1:3001102,VERS=1.2:3010508,VERS=1.4:3030429,VERS=2:3031219,VERS=2.1:3040415,VERS=2.3:3050101,VERS=2.4:3050411,VERS=2.5:3051001,VERS=2.6:3060101,VERS=2.7:3060825,VERS=2.8:3061001,VERS=2.9:3070101,1:"")
  Q IBX
+ ;
 VERSEDT(VERS) ; return Inactive Date of a version of RC files, either version passed in or currently loaded version
  N IBI,LINE,IBX S IBX="" S VERS=+$G(VERS) I 'VERS S VERS=$$VERSION
  I +VERS F IBI=1:1 S LINE=$P($T(VLIST+IBI),";;",2,99) Q:'LINE  I VERS=+LINE S IBX=$P(LINE,U,4)
+ N IBX S:'$G(VERS) VERS=$$VERSION
+ S IBX=$S(VERS=1:3001101,VERS=1.1:3010507,VERS=1.2:3030428,VERS=1.4:3031218,VERS=2:3040414,VERS=2.1:3041231,VERS=2.3:3050410,VERS=2.4:3050930,VERS=2.5:3051231,VERS=2.6:3060824,VERS=2.7:3060930,VERS=2.8:3061231,1:"")
  Q IBX
+ ;
+VERSALL() ; return all RC versions and corresponding effective date 'VERS;EFFDT^VERS;EFFDT^...'
+ N IBI,LINE,IBX,IBC S IBX="",IBC=""
+ F IBI=1:1 S LINE=$P($T(VLIST+IBI),";;",2,99) Q:'LINE  S IBX=IBX_IBC_+LINE_";"_$P(LINE,U,3),IBC=U
+VERSALL() ; returns all RC versions and corresponding effective date
+ N IBX S IBX="1;2990901^1.1;3001102^1.2;3010508^1.4;3030429^2;3031219^2.1;3040415^2.3;3050101^2.4;3050411^2.5;3051001^2.6;3060101^2.7;3060825^2.8;3061001^2.9;3070101"
  Q IBX
+ ;
+VERSEND() ; return all RC versions and corresponding inactive date 'VERS;INACTIVE DT^VERS;INACTIVE DT^...'
+ N IBI,LINE,IBX,IBC S IBX="",IBC=""
+ F IBI=1:1 S LINE=$P($T(VLIST+IBI),";;",2,99) Q:'LINE  I $P(LINE,U,4) S IBX=IBX_IBC_+LINE_";"_$P(LINE,U,4),IBC=U
+VERSEND() ; returns all RC versions and corresponding inactive dates
+ N IBX S IBX="1;3001101^1.1;3010507^1.2;3030428^1.4;3031218^2;3040414^2.1;3041231^2.3;3050410^2.4;3050930^2.5;3051231^2.6;3060824^2.7;3060930^2.8;3061231"
  Q IBX
+ ;
+ ;
 VERSITE(SITE) ; returns the list of versions loaded for a particular site
  ; *** uses 99201 in the RC PHYSICIAN set to check which versions/dates are loaded
  ; *** so 99201 must have a pro charge in all versions, if not it must be replaced with an item that does
  N IBCS,IBXRF,IBITM,IBVERS,IBCSFN,IBI,IBV,IBX,IBY,IBC
+ N IBCS,IBXRF,IBITM,IBVERS,IBCSFN,IBI,IBV,IBX,IBY S IBX=""
  S IBVERS=$$VERSALL,IBITM=99201
+ ;
 …
  . S IBCSFN=$O(^IBE(363.1,"B",IBCS,0)) Q:'IBCSFN  S IBXRF="AIVDTS"_IBCSFN
  . F IBI=1:1 S IBV=$P(IBVERS,U,IBI) Q:'IBV  I $O(^IBA(363.2,IBXRF,IBITM,-$P(IBV,";",2),0)) S IBY(+IBV)=""
+ S IBV="" F  S IBV=$O(IBY(IBV)) Q:'IBV  S IBX=IBX_IBV_","
+ ;
+ S (IBX,IBC)="" F IBI=1:1 S IBV=+$P(IBVERS,U,IBI) Q:'IBV  I $D(IBY(IBV)) S IBX=IBX_IBC_IBV S IBC=","
+ ;
+ I $E(IBX,$L(IBX))="," S IBX=$E(IBX,1,$L(IBX)-1)
  Q IBX
+ ;
 …
+ ;
 MSGVERS(SITE) ; check if versions are being loaded in the correct order, should be loaded in date order
+ ; displays messages to the user:
  ;   - if loading a version that has already been loaded for the site
  ;   - if loading a version when any future versions have already been loaded for the site
 …
  ; *** uses 99201 in the RC PHYSICIAN set to check which versions/dates are loaded
  ; *** so 99201 must have a pro charge in all versions, if not it must be replaced with an item that does
  N IBVERS,IBVDTC,IBVERSIN,IBVERSC,IBVERSO,IBI,VERSTR Q:'$G(SITE)
+ N IBVERS,IBVDTC,IBVERSIN,IBVERSO Q:'$G(SITE)
+ ;
  S IBVERS=$$VERSION Q:'IBVERS  S IBVDTC=$$VERSDT,IBVERSIN=","_$$VERSITE(SITE)_",",IBVERSC=","_IBVERS_","
+ S IBVERS=$$VERSION Q:'IBVERS  S IBVDTC=$$VERSDT,IBVERSIN=","_$$VERSITE(SITE)_","
+ ;
  ; check if loading a version that has already been loaded
  I IBVERSIN[IBVERSC D
+ I IBVERSIN[(","_IBVERS_",") D
  . W !!,?5,"*** It appears version RC v",IBVERS," has already been loaded for this site ***"
+ ;
  ; check if loading a version when any future versions have already been loaded
  S VERSTR=","_$$VERSTR()_",",VERSTR=$P(VERSTR,IBVERSC,2) ; all versions after current version
  F IBI=1:1 S IBVERSO=$P(VERSTR,",",IBI) Q:'IBVERSO  I IBVERSIN[(","_IBVERSO_",")  D
  . W !!,?5,">>> Currently trying to load RC v"_IBVERS_" but RC v"_IBVERSO_" appears to be already",!,?9,"loaded for this site.  The versions should be loaded in date order."
+ F IBVERSO=1,1.1,1.2,1.4,2,2.1,2.3,2.4,2.5,2.6,2.7,2.8,2.9 I IBVERSO>IBVERS D
+ . I IBVERSIN[(","_IBVERSO_",") D
+ .. W !!,?5,">>> Currently trying to load RC v"_IBVERS_" but RC v"_IBVERSO_" appears to be already",!,?9,"loaded for this site.  The versions should be loaded in date order."
+ ;
  ; check if loading a version when the last version has not yet been loaded
  S VERSTR=","_$$VERSTR(1)_",",VERSTR=$P(VERSTR,IBVERSC,2) ; all versions before current version, reverse order
  S IBVERSO=$P(VERSTR,",",1) I +IBVERSO,IBVERSIN'[(","_IBVERSO_",") D
  . W !!,?5,"*** Currently trying to load RC v"_IBVERS_" but RC v"_IBVERSO_" does not appear to be",!,?9,"loaded for this site.  The versions should be loaded in date order."
  . W !!,?5,">>> Continue only if there will never be a need to bill events before ",!,?9,$$FMTE^XLFDT(IBVDTC,2)," for this site.  If RC v"_IBVERSO_" will be needed for this site then",!,?9,"load it first."
+ F IBVERSO=2.9,2.8,2.7,2.6,2.5,2.4,2.3,2.1,2,1.4,1.2,1.1,1 I IBVERS>IBVERSO D  Q
+ . I IBVERSIN'[(","_IBVERSO_",") D
+ .. W !!,?5,"*** Currently trying to load RC v"_IBVERS_" but RC v"_IBVERSO_" does not appear to be",!,?9,"loaded for this site.  The versions should be loaded in date order."
+ .. W !!,?5,">>> Continue only if there will never be a need to bill events before ",!,?9,$$FMTE^XLFDT(IBVDTC,2)," for this site.  If RC v"_IBVERSO_" will be needed for this site then",!,?9,"load it first."
+ ;
+ Q
+ ;
+VERSTR(RVRS) ; returns string containing list of all Reasonable Charges versions with charges, separated by ","
+ ; RVRS - if set, returns the list of versions in reverse order
+ N IBI,LINE,IBS,IBR,IBC,IBX  S (IBS,IBR,IBC,IBX)=""
+ F IBI=1:1 S LINE=$P($T(VLIST+IBI),";;",2,99) Q:'LINE  S IBS=IBS_IBC_+LINE,IBR=+LINE_IBC_IBR S IBC=","
+ S IBX=IBS I +$G(RVRS) S IBX=IBR
+ Q IBX
+FILES(IBFILES,VERS) ; source Host file name, description, and routine label that parses the file
+ ; the subscript used for the file in XTMP is 'IBCR RC '_X w/ X=the routine label that parses the file
+ ;
+ I $G(VERS)=1.1 G FBREAL
+ I $G(VERS)=1.2 G FCREAL
+ I $G(VERS)=1.4 G FDREAL
+ I $G(VERS)=2 G FEREAL
+ I $G(VERS)=2.1 G FFREAL
+ I $G(VERS)=2.3 G FGREAL
+ I $G(VERS)=2.4 G FHREAL
+ I $G(VERS)=2.5 G FIREAL^IBCRHBV1
+ I $G(VERS)=2.6 G FJREAL^IBCRHBV1
+ I $G(VERS)=2.7 G FKREAL^IBCRHBV1
+ I $G(VERS)=2.8 G FLREAL^IBCRHBV1
+ I $G(VERS)=2.9 G FMREAL^IBCRHBV1
+ ;
+ ;
+ ;
+ ;
+ ;
+ ;
+ ; File Names:  'IBRCyymmx.TXT'   w/ yymm - year month of version release (except v1)
+ ;              'IBRCyymm', file version identifier prefix, from VLIST text version description
+ ;              x=A-I/F, single character file identifier, from FTYPE text file description
+ ;
+FILES(IBFILES,VERS) ; returns array of source Host Files and data for version requested, pass IBFILES by reference
+ N IBI,LINE,IBTYPE,IBFILE,IBNAME,IBDESC S VERS=+$G(VERS) I 'VERS S VERS=1
+ ;
+ ; get requested versions data
+ F IBI=1:1 S LINE=$P($T(VLIST+IBI),";;",2,99) Q:'LINE  I VERS=+LINE S IBTYPE=$P(LINE,U,2),IBFILE=$P(LINE,U,5) Q
+ ;
+ ; get requested versions files
+ I +$G(IBTYPE) F IBI=1:1 S LINE=$P($T(@("FT"_IBTYPE)+IBI),";;",2,99) Q:LINE=""  D
+ . S IBNAME=IBFILE_$P(LINE,":",1)_".TXT",IBDESC="RC v"_+VERS_" "_$P(LINE,":",2,99)
+ . S IBFILES(IBNAME)=IBDESC
+FREAL S IBFILES("IBRCVA.TXT")="RC v1 Inpatient Facility Charges^A"
+ S IBFILES("IBRCVB.TXT")="RC v1 Inpatient Facility Area Factors^B"
+ S IBFILES("IBRCVC.TXT")="RC v1 Outpatient Facility Charges^C"
+ S IBFILES("IBRCVD.TXT")="RC v1 Outpatient Facility Area Factors^D"
+ S IBFILES("IBRCVE.TXT")="RC v1 Physician Charges E^E"
+ S IBFILES("IBRCVF.TXT")="RC v1 Physician Charges F^F"
+ S IBFILES("IBRCVG.TXT")="RC v1 Physician Charges G^G"
+ S IBFILES("IBRCVH.TXT")="RC v1 Physician Area Factors^H"
+ S IBFILES("IBRCVI.TXT")="RC v1 Physician Unit Area Factors^I"
+ Q
+ ;
+FBREAL S IBFILES("IBRC0011A.TXT")="RC v1.1 Inpatient Facility Charges^A"
+ S IBFILES("IBRC0011B.TXT")="RC v1.1 Inpatient Facility Area Factors^B"
+ S IBFILES("IBRC0011C.TXT")="RC v1.1 Outpatient Facility Charges^C"
+ S IBFILES("IBRC0011D.TXT")="RC v1.1 Outpatient Facility Area Factors^D"
+ S IBFILES("IBRC0011E.TXT")="RC v1.1 Physician Charges E^E"
+ S IBFILES("IBRC0011F.TXT")="RC v1.1 Physician Charges F^F"
+ S IBFILES("IBRC0011G.TXT")="RC v1.1 Physician Charges G^G"
+ S IBFILES("IBRC0011H.TXT")="RC v1.1 Physician Area Factors^H"
+ S IBFILES("IBRC0011I.TXT")="RC v1.1 Physician Unit Area Factors^I"
+ Q
+ ;
+ ; versions and their critical data, add new versions here
+VLIST ; version ^ file type/version ^ effective date ^ inactive date ^ file prefix
+ ;;1.0^1^2990901^3001101^IBRCV
+ ;;1.1^1^3001102^3010507^IBRC0011
+ ;;1.2^1^3010508^3030428^IBRC0105
+ ;;1.4^1^3030429^3031218^IBRC0304
+ ;;2.0^2^3031219^3040414^IBRC0312
+ ;;2.1^2^3040415^3041231^IBRC0404
+ ;;2.3^2^3050101^3050410^IBRC0501
+ ;;2.4^2^3050411^3050930^IBRC0504
+ ;;2.5^2^3051001^3051231^IBRC0510
+ ;;2.6^2^3060101^3060824^IBRC0601
+ ;;2.7^2^3060825^3060930^IBRC0608
+ ;;2.8^2^3061001^3061231^IBRC0610
+ ;;2.9^2^3070101^3070930^IBRC0701
+ ;;2.11^2^3071001^3071231^IBRC0710
+ ;;3.1^2^3080101^^IBRC0801
+ ;;
+ ;
+ ;
+ ;
+ ;
+ ;
+ ;
+ ;
+FTYPE ; file type/versions and relevant data
+ ; file identifer is used with XTMP subscript 'IBCR RC ' and routine label to parse file
+ ; file identifier : file name/description ^ file identifier ^ number of columns (for v2+)
+FCREAL S IBFILES("IBRC0105A.TXT")="RC v1.2 Inpatient Facility Charges^A"
+ S IBFILES("IBRC0105B.TXT")="RC v1.2 Inpatient Facility Area Factors^B"
+ S IBFILES("IBRC0105C.TXT")="RC v1.2 Outpatient Facility Charges^C"
+ S IBFILES("IBRC0105D.TXT")="RC v1.2 Outpatient Facility Area Factors^D"
+ S IBFILES("IBRC0105E.TXT")="RC v1.2 Physician Charges E^E"
+ S IBFILES("IBRC0105F.TXT")="RC v1.2 Physician Charges F^F"
+ S IBFILES("IBRC0105G.TXT")="RC v1.2 Physician Charges G^G"
+ S IBFILES("IBRC0105H.TXT")="RC v1.2 Physician Area Factors^H"
+ S IBFILES("IBRC0105I.TXT")="RC v1.2 Physician Unit Area Factors^I"
+ Q
+ ;
+FT1 ; Reasonable Charge File Type 1 files
+ ;;A:Inpatient Facility Charges^A
+ ;;B:Inpatient Facility Area Factors^B
+ ;;C:Outpatient Facility Charges^C
+ ;;D:Outpatient Facility Area Factors^D
+ ;;E:Physician Charges E^E
+ ;;F:Physician Charges F^F
+ ;;G:Physician Charges G^G
+ ;;H:Physician Area Factors^H
+ ;;I:Physician Unit Area Factors^I
+ ;;
+FDREAL S IBFILES("IBRC0304A.TXT")="RC v1.4 Inpatient Facility Charges^A"
+ S IBFILES("IBRC0304B.TXT")="RC v1.4 Inpatient Facility Area Factors^B"
+ S IBFILES("IBRC0304C.TXT")="RC v1.4 Outpatient Facility Charges^C"
+ S IBFILES("IBRC0304D.TXT")="RC v1.4 Outpatient Facility Area Factors^D"
+ S IBFILES("IBRC0304E.TXT")="RC v1.4 Physician Charges E^E"
+ S IBFILES("IBRC0304F.TXT")="RC v1.4 Physician Charges F^F"
+ S IBFILES("IBRC0304G.TXT")="RC v1.4 Physician Charges G^G"
+ S IBFILES("IBRC0304H.TXT")="RC v1.4 Physician Area Factors^H"
+ S IBFILES("IBRC0304I.TXT")="RC v1.4 Physician Unit Area Factors^I"
+ Q
+ ;
+FT2 ; Reasonable Charges File Type 2 files
+ ;;A:Inpatient Facility Charges^A^10
+ ;;B:Outpatient Facility Charges^B^14
+ ;;C:Professional Charges^C^23
+ ;;D:Service Category Codes^D^4
+ ;;E:Area Factors^E^41
+ ;;F:VA Sites and Zip Codes^F^4
+ ;;
+FEREAL S IBFILES("IBRC0312A.TXT")="RC v2.0 Inpatient Facility Charges^A^10"
+ S IBFILES("IBRC0312B.TXT")="RC v2.0 Outpatient Facility Charges^B^14"
+ S IBFILES("IBRC0312C.TXT")="RC v2.0 Professional Charges^C^23"
+ S IBFILES("IBRC0312D.TXT")="RC v2.0 Service Category Codes^D^4"
+ S IBFILES("IBRC0312E.TXT")="RC v2.0 Area Factors^E^41"
+ S IBFILES("IBRC0312F.TXT")="RC v2.0 VA Sites and Zip Codes^F^4"
+ Q
+ ;
+FFREAL S IBFILES("IBRC0404A.TXT")="RC v2.1 Inpatient Facility Charges^A^10"
+ S IBFILES("IBRC0404B.TXT")="RC v2.1 Outpatient Facility Charges^B^14"
+ S IBFILES("IBRC0404C.TXT")="RC v2.1 Professional Charges^C^23"
+ S IBFILES("IBRC0404D.TXT")="RC v2.1 Service Category Codes^D^4"
+ S IBFILES("IBRC0404E.TXT")="RC v2.1 Area Factors^E^41"
+ S IBFILES("IBRC0404F.TXT")="RC v2.1 VA Sites and Zip Codes^F^4"
+ Q
+ ;
+FGREAL S IBFILES("IBRC0501A.TXT")="RC v2.3 Inpatient Facility Charges^A^10"
+ S IBFILES("IBRC0501B.TXT")="RC v2.3 Outpatient Facility Charges^B^14"
+ S IBFILES("IBRC0501C.TXT")="RC v2.3 Professional Charges^C^23"
+ S IBFILES("IBRC0501D.TXT")="RC v2.3 Service Category Codes^D^4"
+ S IBFILES("IBRC0501E.TXT")="RC v2.3 Area Factors^E^41"
+ S IBFILES("IBRC0501F.TXT")="RC v2.3 VA Sites and Zip Codes^F^4"
+ Q
+ ;
+FHREAL S IBFILES("IBRC0504A.TXT")="RC v2.4 Inpatient Facility Charges^A^10"
+ S IBFILES("IBRC0504B.TXT")="RC v2.4 Outpatient Facility Charges^B^14"
+ S IBFILES("IBRC0504C.TXT")="RC v2.4 Professional Charges^C^23"
+ S IBFILES("IBRC0504D.TXT")="RC v2.4 Service Category Codes^D^4"
+ S IBFILES("IBRC0504E.TXT")="RC v2.4 Area Factors^E^41"
+ S IBFILES("IBRC0504F.TXT")="RC v2.4 VA Sites and Zip Codes^F^4"
+ Q

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRHBS8.m

r628	r636
1	1	IBCRHBS8 ;ALB/ARH - RATES: UPLOAD (RC 2+) CALCULATIONS CHARGE ; 10-OCT-03
2		;;2.0;INTEGRATED BILLING;245~~,382;21-MAR-94;Build 2~~
3		;;Per VHA Directive ~~2004-038~~, this routine should not be modified.
	2	;;2.0;INTEGRATED BILLING;245;21-MAR-94
	3	;;Per VHA Directive 10-93-142, this routine should not be modified.
4	4	;
5	5	;
…	…
49	49	;
50	50	ISNF(SITE,ITLINE) ; Return Inpatient Skilled Nursing Facility Per Diem
51		N IBCHG,IBZIP,IBAA S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
52		I $P(ITLINE,U,2)'="SNF" G ISNFQ
53		I $P(ITLINE,U,1)'="999",$P(ITLINE,U,1)'="000" G ISNFQ
	51	N IBCHG,IBZIP,IBAA S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4) I $P(ITLINE,U,2)'="SNF" G ISNFQ
	52	I $P(ITLINE,U,1)'="999" G ISNFQ
54	53	;
55	54	S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G ISNFQ

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC3.m

-              r628
+              r636
 IBCSC3 ;ALB/MJB - MCCR SCREEN 3 (PAYER/MAILING ADDRESS) ;27 MAY 88 10:15
  ;;2.0;INTEGRATED BILLING;**8,43,52,80,82,51,137,232,320,377**;21-MAR-94;Build 23
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**8,43,52,80,82,51,137,232,320**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
  ;MAP TO DGCRSC3
 …
  F I=0,"M","M1","U","U2" S IB(I)=$S($D(^DGCR(399,IBIFN,I)):(^(I)),1:"")
  S IBOUTP=2,IBINDT=$S(+$G(IB("U")):+IB("U"),1:DT)
+ ;S Z=1,IBW=1 X IBWW W " Rate Type  : ",$S($P(IB(0),U,7)']"":IBU,$D(^DGCR(399.3,$P(IB(0),U,7),0)):$P(^(0),U),1:IBUN)
+ ;
  S X=" Rate Type  : "_$S($P(IB(0),U,7)']"":IBU,$D(^DGCR(399.3,$P(IB(0),U,7),0)):$P(^(0),U),1:IBUN)
 …
  I $P(IB(0),U,11)="i" I $D(IBDD)>1,$D(^DGCR(399,IBIFN,"AIC")) G SHW
  D UP G LST:$D(IBDD)>1 W !?4,"Insurance : NO REIMBURSABLE INSURANCE INFORMATION ON FILE",!?17,"[Add Insurance Information by entering '1' at the prompt below]" G MAIL
+ ;
+ ;W !?4,"Insurance Carrier",?40,"Whose",?66,"Relationship" S X="",$P(X,"=",81)="" W !,X
 LST N IBDTIN,IBICT
  S IBDTIN=+$G(IB("U")),IBICT=0
 …
 SHW I $D(IBDD) S I="" F  S I=$O(IBDD(I)) Q:'I  D SHW1
 MAIL I $$BUFFER^IBCNBU1(DFN) W !!,?17,"***  Patient has Insurance Buffer entries  ***"
+ ;
  S IB("M")=$S($D(^DGCR(399,IBIFN,"M")):^("M"),1:""),IB("M1")=$S($D(^DGCR(399,IBIFN,"M1")):^("M1"),1:""),IB(0)=^DGCR(399,IBIFN,0)
  S Z=2,IBW=1 W ! X IBWW
 …
  S IB("RAFLAG",2)=$S($P(IB("M"),U,2)="":0,1:$$GET1^DIQ(36,$P(IB("M"),U,2),IBRAMS,"I"))
  S IB("RAFLAG",3)=$S($P(IB("M"),U,3)="":0,1:$$GET1^DIQ(36,$P(IB("M"),U,3),IBRAMS,"I"))
+ S X=0
+ I $P(IB("M1"),U,2)="",'IB("RAFLAG",1),$P(IB("M1"),U,3)="",'IB("RAFLAG",2),$P(IB("M1"),U,4)="",'IB("RAFLAG",3) S X=1
+ W " Billing Provider Secondary IDs: "
+ I X W IBUN          ; no data found, unspecified not required
+ I 'X D              ; data found, display below
+ . W !?5,"Primary Payer: ",$S($P(IB("M1"),U,2)]"":$P(IB("M1"),U,2),IB("RAFLAG",1):"ATT/REND ID",1:"")
+ . W !?5,"Secondary Payer: ",$S($P(IB("M1"),U,3)]"":$P(IB("M1"),U,3),IB("RAFLAG",2):"ATT/REND ID",1:"")
+ . W ?46,"Tertiary Payer: ",$S($P(IB("M1"),U,4)]"":$P(IB("M1"),U,4),IB("RAFLAG",3):"ATT/REND ID",1:"")
+ . Q
+ ;
+ S X=0 I $P(IB("M1"),U,2)="",'IB("RAFLAG",1),$P(IB("M1"),U,3)="",'IB("RAFLAG",2),$P(IB("M1"),U,4)="",'IB("RAFLAG",3) S X=1 W " Facility ID #s: ",IBUN
+ I 'X D
+ . W " Primary Payer: ",$S($P(IB("M1"),U,2)]"":$P(IB("M1"),U,2),IB("RAFLAG",1):"ATT/REND ID",1:"")
+ . W !?4,"Secondary Payer: ",$S($P(IB("M1"),U,3)]"":$P(IB("M1"),U,3),IB("RAFLAG",2):"ATT/REND ID",1:"")
+ . W ?45,"Tertiary Payer: ",$S($P(IB("M1"),U,4)]"":$P(IB("M1"),U,4),IB("RAFLAG",3):"ATT/REND ID",1:"")
  S Z=3,IBW=1 W ! X IBWW
  W " Mailing Address : "

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC5.m

-              r628
+              r636
 IBCSC5 ;ALB/MJB - MCCR SCREEN 5 (OPT. EOC) ;27 MAY 88 10:15
  ;;2.0;INTEGRATED BILLING;**52,125,51,210,266,288,287,309,389**;21-MAR-94;Build 6
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**52,125,51,210,266,288,287,309**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
  ;MAP TO DGCRSC5
 …
  . S IBY=0 F  S IBY=$O(^IBA(362.5,"AIFN"_IBIFN,IBX,IBY)) Q:'IBY  S IBZ=$G(^IBA(362.5,IBY,0)) I IBZ'="" D  Q:X>5
  .. S X=X+1 I X>5 W !,?17,"*** There are more Pros. Items associated with this bill.***" Q
+ .. W:X'=1 ! W ?17,$E($P(IBZ,U,5),1,40),?67,$$FMTE^XLFDT(+IBZ)
+ .. ;S IBN=$G(^RMPR(661,+$P(IBZ,U,3),0)) W:X'=1 ! W ?17,$E($$PIN^IBCSC5B(+IBN),1,35)," - ",$P(IBN,U,1),?65,$$FMTE^XLFDT(+IBZ)
+ .. S IBN=$$PIN^IBCSC5B(+$P(IBZ,U,3)) W:X'=1 ! W ?17,$E($P(IBN,U,2),1,35)," - ",$P(IBN,U,1),?65,$$FMTE^XLFDT(+IBZ)
  Q X
+ ;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC5B.m

-              r628
+              r636
 IBCSC5B ;ALB/ARH - ADD/ENTER PROSTHETIC ITEMS ;12/28/93
  ;;2.0;INTEGRATED BILLING;**4,52,260,339,389**;21-MAR-94;Build 6
+ ;;2.0;INTEGRATED BILLING;**4,52,260,339**;21-MAR-94;Build 2
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+ ;
+EN ; add/edit prosthetic items for a bill, IBIFN required
+ N IBX,DFN,IBDT1,IBDT2,IBACTION,BIFN,APROS,ALPROS,ABILL,ALBILL
+EN ;add/edit prosthetic items for a bill, IBIFN required
  S IBX=$$BILL(IBIFN) Q:'IBIFN  S DFN=+IBX,IBDT1=$P(IBX,U,2),IBDT2=$P(IBX,U,3)
+ D SET(IBIFN,.IBPDA),PIDISP(DFN,IBDT1,IBDT2,.IBPDE,.IBPDA),DISP(.IBPDA)
+E1 S IBPIFN=0,IBDT=$$ASKDT(IBDT1,IBDT2) G:'IBDT EXIT
+ S IBPD=$O(IBPDA(IBDT,0)) S:'IBPD IBPD=$O(IBPDE(IBDT,0)) S IBPD=$$ASKPD(IBPD) G:'IBPD E1
+ S IBPIFN=$G(IBPDA(IBDT,+IBPD)) I 'IBPIFN S IBPIFN=$$ADD(IBDT,IBIFN,+IBPD,+$G(IBPDE(IBDT,+IBPD))) I 'IBPIFN W " ??" G E1
+ I '$D(IBPDE(IBDT,+IBPD)) W !,"This prosthetic item does not exist in this patients prosthetics record.",!
+ D EDIT(+IBPIFN) D SET(IBIFN,.IBPDA) W ! G E1
+ ;
+EN1 D PISET(DFN,IBDT1,IBDT2,.APROS,.ALPROS) D SET(IBIFN,.ABILL,.ALBILL,+$G(APROS))
+ D PIDISP(.APROS,.ALPROS,.ABILL) D DISP(.ABILL,.ALBILL) S BIFN=""
+ ;
+ S IBACTION=$$SELECT(.ALPROS,.ALBILL) Q:'IBACTION
+ I +IBACTION=1 S BIFN=$$ADD(IBIFN,$P(IBACTION,U,2),$P(IBACTION,U,3)) G EN1
+ I +IBACTION=2 S BIFN=+$G(ABILL(+$P(IBACTION,U,2),$P(IBACTION,U,3)))
+ I +IBACTION=3 S IBX=$$ASKITM(IBDT1,IBDT2) I +IBX S BIFN=$$ADD(IBIFN,+IBX,,$P(IBX,U,2))
+ I +BIFN D EDIT(BIFN)
+ ;
+ G EN1
+EXIT K IBPIFN,IBX,IBDT1,IBDT2,IBPDA,IBPDE,IBPD,IBDT
+ Q
+ ;
+SELECT(ALPROS,ALBILL) ; get which item to add/edit, select from Patient Prosthetics, Bill Items, or add a new one
+ ; returns 1 ^ PD DEL DATE ^ PI IFN - ALPROS(selected item) if item from Prosthetics selected
+ ;         2 ^ PD DEL DATE ^ X      - ALBILL(selected item) if item existing on bill selected
+ ;         3 if add new item, "" if exit, -1 if redo
+ N IBX,IBY,IBZ,DIR,DTOUT,DUOUT,DIRUT,X,Y S IBY=""
+ S DIR("?")="Select the Prosthetics Item to Add or Edit."
+ S DIR("?",1)="Enter the number preceding the Item to Add or Edit."
+ S DIR("?",2)="Or enter the Item name to add an item not in the list and not in Prosthetics.",DIR("?",3)=" "
+ASKDT(IBDT1,IBDT2,IBDT) ;
+ I +$G(IBIFN) S DIR("?")="Enter the date the item was delivered to the patient",DIR("??")="^D HELP^IBCSC5B("_IBIFN_")"
+ S DIR("A")="Select ITEM DELIVERY DATE",DIR(0)="DO^"_IBDT1_":"_IBDT2_":EX" D ^DIR K DIR,DTOUT,DIRUT
+ Q $S(Y?7N:Y,1:0)
+ ;
+ S DIR("A")="Select Prosthetics Item",DIR(0)="FO^1:20^K:X?1N1P.NP X" D ^DIR S IBX=Y I $D(DIRUT) G SELECTQ
+ASKPD(PD) ;
+ N X,Y
+ S DIR("A")="Select PROSTHETIC ITEM",DIR(0)="660,4O" S:+$G(PD) DIR("B")=+$G(^RMPR(661,+$G(PD),0)) D ^DIR S:$D(DIRUT)!(Y'>0) Y="" K DIR,DIRUT
+ Q Y
+ ;
+ S IBZ=$G(ALPROS(IBX)) I +IBZ W "  adding ",IBX S IBY="1^"_IBZ G SELECTQ
+ S IBZ=$G(ALBILL(IBX)) I +IBZ W "  editing ",IBX S IBY="2^"_IBZ G SELECTQ
+ADD(IBDT,IFN,IBPD,PIFN) ;
+ N IBX,IBY,IBDX,IBHCPCS S IBX=0,DIC="^IBA(362.5,",DIC(0)="AQL",X=IBDT K DA,DO D FILE^DICN K DA,DO,X
+ I Y>0 S DIE=DIC,(IBX,DA)=+Y,DR=".02////"_IFN_";.03////"_IBPD_";.04////"_PIFN D ^DIE K DIE,DIC,DA,DR W "... ADDED"
+ ;add dx if known
+ F IBY=1:1:4 S IBDX=+$G(^RMPR(660,PIFN,"BA"_IBY)) I IBDX,'$O(^IBA(362.3,"AIFN"_IFN,IBDX)) D
+ . S DIC="^IBA(362.3,",DIC(0)="L",DLAYGO=362.3,X=IBDX,DIC("DR")=".02////"_IFN K DD,DO D FILE^DICN S IBDX(+Y)=""
+ ;add hcpcs if known
+ ;S IBHCPCS=$P($G(^RMPR(660,PIEN,0)),"^",22) I IBHCPCS
+ ;
  S DIR(0)="YO",DIR("A")="Add a New Item",DIR("B")="YES" D ^DIR K DIR S IBY=-1 I Y=1,'$D(DIRUT) S IBY=3
+ Q IBX
+ ;
+SELECTQ Q IBY
+ ;
+ASKITM(IBDT1,IBDT2) ; Ask for new item data when adding an item not in Prosthetics
+ ; returns:  delivery date ^ prosthetic item name (from 661.1, .02)
+ N DIR,DIC,DIE,DTOUT,DUOUT,DIRUT,X,Y,IBX,IBY S (IBX,IBY)="" I '$G(IBDT1)!'$G(IBDT2) G ASKITMQ
+ ;
+ W !!,"Enter a Prosthetics Item that does not have a Prosthetics Patient record.",!
+ S DIR("A")="Select ITEM DELIVERY DATE",DIR(0)="DO^"_IBDT1_":"_IBDT2_":EX" D ^DIR S IBX=Y I Y'?7N G ASKITMQ
+ ;
+ S DIC="^RMPR(661.1,",DIC(0)="AENOQMZ",DIC("S")="I +$P(^(0),U,5)",DIC("A")="Select PROSTHETICS ITEM: " D ^DIC
+ ;
+ I +Y>0,+IBX S IBY=IBX_U_$P($G(Y(0)),U,2)
+ ;
+ASKITMQ Q IBY
+ ;
+ADD(IBIFN,IBDT,PIFN,IBPNAME) ; Add new Item to Bill (#362.5)
+ N IBX,IBY,IBDX,IBHCPCS,DIC,DIE,DA,DR,DLAYGO,X,Y S IBY=0,PIFN=+$G(PIFN) I ($G(IBDT)'?7N)!('$G(IBIFN)) G ADDQ
+ ;
+ I $G(PIFN),$$ONBILLPI(IBIFN,PIFN) G ADDQ ; don't add duplicates
+ I $G(IBPNAME)="" S IBPNAME=$P($$PIN(PIFN),U,2) I IBPNAME="" G ADDQ
+ ;
+ S DIC="^IBA(362.5,",DIC(0)="AQL",DLAYGO=362.5,X=IBDT K DA,DO D FILE^DICN K DA,DO,X
+ I Y>0 S (IBY,DA)=+Y,DIE=DIC,DR=".02////"_IBIFN_";.04////"_+PIFN_";.05///^S X=IBPNAME" D ^DIE K DIE,DA,DR W "... ADDED"
+ ;
+ ;add dx if known
+ I +IBY,+PIFN F IBX=1:1:4 S IBDX=+$G(^RMPR(660,PIFN,"BA"_IBX)) I IBDX,'$O(^IBA(362.3,"AIFN"_IBIFN,IBDX)) D
+ . S DIC="^IBA(362.3,",DIC(0)="L",DLAYGO=362.3,X=IBDX,DIC("DR")=".02////"_IBIFN K DD,DO D FILE^DICN S IBDX(+Y)=""
+ ;add hcpcs if known ;S IBHCPCS=$P($G(^RMPR(660,PIEN,0)),"^",22) I IBHCPCS
+ ;
+ADDQ Q IBY
+ ;
+EDIT(BIFN) ;
+ N DIDEL,DIE,DIC,DR,DA,X,Y Q:'$G(BIFN)  W ! S DIDEL=362.5,DIE="^IBA(362.5,",DR=".01;.05",DA=BIFN D ^DIE
+EDIT(PIFN) ;
+ S DIDEL=362.5,DIE="^IBA(362.5,",DR=".01;.03",DA=PIFN D ^DIE K DIE,DR,DA,DIC,DIDEL
+ Q
+ ;
+SET(IBIFN,ARRB,ARRBL,PICNT) ; setup array of all prosthetic devices on bill (#362.5), array names should be passed by reference
+ ; input:   PICNT - the number of items found in prosthetics (PISET)
+ ; output:  ARRB(PD DELIV DATE, X) = PD IFN (362.5 ptr) ^ Cost,  ARRB = BILL IFN ^ count of items on bill
+ ;          ARRBL(PICNT + count of item on bill) = PD DELIV DATE ^ X
+ ;          where X is the IFN of the Patient Item (660 ptr) or if not defined then a number_"Z"
+ N CNT,IBX,IBY,BIFN,RIFN,IBC,IBRC K ARRB,ARRBL S IBC="AIFN"_$G(IBIFN),ARRB="^0" Q:'$G(IBIFN)
+ D RCITEM^IBCSC5A(IBIFN,"IBRC",5) S CNT=0
+ ;
+ S IBX=0 F  S IBX=$O(^IBA(362.5,IBC,IBX)) Q:'IBX  S BIFN=0 F  S BIFN=$O(^IBA(362.5,IBC,IBX,BIFN)) Q:'BIFN  D
+ . S IBY=$G(^IBA(362.5,BIFN,0)) Q:IBY=""  S CNT=CNT+1,RIFN=+$P(IBY,U,4),RIFN=$S(+RIFN:+RIFN,1:CNT_"Z")
+ . S ARRB(+IBY,RIFN)=BIFN_U_$$CHG^IBCF4(BIFN,5,.IBRC),ARRB=$G(ARRB)+1
+ S ARRB=IBIFN_U_+$G(ARRB)
+ ;
+ S CNT=+$G(PICNT),IBX=0 F  S IBX=$O(ARRB(IBX)) Q:'IBX  S IBY=0 F  S IBY=$O(ARRB(IBX,IBY)) Q:'IBY  S CNT=CNT+1,ARRBL(CNT)=IBX_U_IBY
+SET(IFN,PDARR) ;setup array of all prosthetic devices for bill, array name should be passed by reference
+ ;returns: PDARR(PD DELIV DATE, PD ITEM (661 ptr))=PD IFN (362.5 ptr),  PDARR=BILL IFN ^ PD count
+ N CNT,IBX,IBY,PIFN,IBC,IBRC K PDARR S IBC="AIFN"_$G(IFN)
+ D RCITEM^IBCSC5A(IBIFN,"IBRC",5)
+ S (CNT,IBX)=0 F  S IBX=$O(^IBA(362.5,IBC,IBX)) Q:'IBX  S PIFN=0 F  S PIFN=$O(^IBA(362.5,IBC,IBX,PIFN)) Q:'PIFN  D
+ . S IBY=$G(^IBA(362.5,PIFN,0)) Q:IBY=""  S CNT=CNT+1,PDARR(+IBY,$P(IBY,U,3))=PIFN_U_$$CHG^IBCF4(PIFN,5,.IBRC)
+ S PDARR=$G(IFN)_"^"_CNT
+ Q
+ ;
+DISP(ABILL,ALBILL) ;screen display of existing prosthetic devices for a bill, arrays should be passed by reference
+ ; input:  ABILL (from SET) list of bill items
+ ;         ALBILL (from SET) list of bill items, in count order
+ N IBC,IBI,BIFN,BIFN0,DDT
+ ;
+DISP(PDARR) ;screen display of existing prosthetic devices for a bill,
+ ;input should be array returned by SET^IBCSC5B: PDARR(PD DT, PD ITEM)=PD IFN (362.5), pass by reference
+ N IBX,IBY,IBZ
  W !!,?5,"-----------------  Existing Prosthetic Items for Bill  -----------------",!
+ S IBC=0 F  S IBC=$O(ALBILL(IBC)) Q:'IBC  D
+ . S DDT=+ALBILL(IBC),IBI=$P(ALBILL(IBC),U,2),BIFN=+$G(ABILL(DDT,IBI)),BIFN0=$G(^IBA(362.5,BIFN,0))
+ . W !,?1,$J(IBC,2),")",?6,$$DATE(DDT),?16,$E($P(BIFN0,U,5),1,60)
+ S IBX=0 F  S IBX=$O(PDARR(IBX)) Q:IBX=""  S IBY=0 F  S IBY=$O(PDARR(IBX,IBY)) Q:'IBY  D
+ . S IBZ=$$PIN(IBY) W !,$$DATE(IBX),?12,$P(IBZ,U,1),?20,$P(IBZ,U,2)
  W !
+ Q
+ ;
+PISET(DFN,DT1,DT2,ARRP,ARRPL) ; get all prosthetic items (660) for a patient and date range, arrays should pass by ref.
+ ; input:   DFN = patient, DT1-DT2 range of dates to search for items
+ ; output:  ARRP(PD DEL DATE (660,10), PI IFN (660 ptr)) = PI IFN (660 ptr),  ARRP = count of items
+ ;          ARRPL(count) = PD DEL DATE (660,10) ^ PI IFN (660 ptr)
+ ;
+ N PIFN,DDT,IBX,IBY,CNT K ARRP,ARRPL Q:'$G(DFN)  S DT1=$G(DT1)-.0001,DT2=$G(DT2) S:'DT2 DT2=9999999
+ S PIFN=0 F  S PIFN=$O(^RMPR(660,"C",DFN,PIFN)) Q:'PIFN  D
+ . S IBX=$G(^RMPR(660,PIFN,0)) Q:IBX=""  S DDT=+$P(IBX,U,12)\1 I (DDT<DT1)!(DDT>DT2) Q
+ . S ARRP(DDT,PIFN)=PIFN,ARRP=+$G(ARRP)+1
+ ;
+ S (CNT,IBX)=0 F  S IBX=$O(ARRP(IBX)) Q:'IBX  S IBY=0 F  S IBY=$O(ARRP(IBX,IBY)) Q:'IBY  S CNT=CNT+1,ARRPL(CNT)=IBX_U_IBY
+HELP(IFN) ;called for help from prosthetics enter to display existing devices, displays devices from 660 and 399
+ I +$G(IFN) N IBX,IBPDA S IBX=$$BILL(IFN) I +IBX D SET(IFN,.IBPDA),PIDISP($P(IBX,U,1),$P(IBX,U,2),$P(IBX,U,3),"",.IBPDA),DISP(.IBPDA)
+ Q
+ ;
+PIDISP(APROS,ALPROS,ABILL) ; display all prosthetic items (#660) for a patient and date range, arrays passed by reference, not changed
+ ; input:  APROS (from PISET) patient's prosthetic items
+ ;         ALPROS (from PISET) patient's prosthetics items, in count order
+ ;         ABILL (from SET) list of bill's prosthetics items, only to check if item on bill
+ N IBC,DDT,PIFN,PNAME,IBY,IBX,IBICD,IBP,IBEX
+PIDISP(DFN,DT1,DT2,ARRAY,PDARR) ; display all prosthetic items (660) for a patient and date range
+ ;PDARR (as defined by SET^IBCSC5B) passed by ref. only to check if pros. item is on the bill, not necessary, not changed
+ ;returns ARRAY(PD DEL DATE (660,10), PD ITEM (660,4=661 ptr))=RECORD (660 ptr), should pass by ref. if desired
+ N PIFN,IBX,IBY,PNAME,DDT,PI,IBICD,IBEX,IBP
+ K ARRAY S DT1=$G(DT1)-.0001,DT2=$G(DT2) S:'DT2 DT2=9999999 Q:'$G(DFN)
+ S PIFN=0 F  S PIFN=$O(^RMPR(660,"C",DFN,PIFN)) Q:'PIFN  D
+ . S IBX=$G(^RMPR(660,PIFN,0)),DDT=+$P(IBX,U,12)\1 I (DDT<DT1)!(DDT>DT2) Q
+ . S ARRAY(DDT,+$P(IBX,U,6))=PIFN
+ ;
+ W @IOF,?33,"PROSTHETICS SCREEN"
+ W !,"================================================================================",!
+ S IBC=0 F  S IBC=$O(ALPROS(IBC)) Q:'IBC  D
+ . S DDT=+ALPROS(IBC),PIFN=$P(ALPROS(IBC),U,2)
+ . S PNAME=$$PIN(PIFN),IBY=$G(^RMPR(660,PIFN,"AM")),IBX=$G(^RMPR(660,PIFN,0)) K IBEX
+ . ;
+ . F IBICD=1:1:4 Q:$D(IBEX)  I $D(^RMPR(660,PIFN,"BA"_IBICD)) F IBP=2:1:8 I $P(^RMPR(660,PIFN,"BA"_IBICD),"^",IBP) S IBEX="("_$P($T(EXEMPT+(IBP-1)),";",3)_")" Q  ; look for exemption info
+ . ;
+ . W !,$S($D(ABILL(+DDT,PIFN)):"*",1:"")
+ . W ?1,$J(IBC,2),")",?6,$$DATE(DDT),?16,$E($P(PNAME,U,2),1,27),?45,"("_$P(PNAME,U,3),")",?53,$G(IBEX),?59,$E($$EXSET^IBEFUNC($P(IBX,U,14),660,12),1,4),?64,$$EXSET^IBEFUNC($P(IBY,U,3),660,62),?71,$J(+$P(IBX,U,16),8,2)
+ W @IOF,?33,"PROSTHETICS SCREEN",!,"================================================================================",!
+ S DDT=0 F  S DDT=$O(ARRAY(DDT)) Q:'DDT  S PI=0 F  S PI=$O(ARRAY(DDT,PI)) Q:'PI  D
+ . S PIFN=ARRAY(DDT,PI),PNAME=$$PIN(PI),IBY=$G(^RMPR(660,PIFN,"AM")),IBX=$G(^RMPR(660,PIFN,0)) K IBEX
+ . ; look for exemption info
+ . F IBICD=1:1:4 Q:$D(IBEX)  I $D(^RMPR(660,PIFN,"BA"_IBICD)) F IBP=2:1:8 I $P(^RMPR(660,PIFN,"BA"_IBICD),"^",IBP) S IBEX="("_$P($T(EXEMPT+(IBP-1)),";",3)_")" Q
+ . W !,$S($D(PDARR(+DDT,PI)):"*",1:"")
+ . W ?2,$$DATE(DDT),?12,$P(PNAME,U,1),$G(IBEX),?20,$E($P(PNAME,U,2),1,30),?55,$E($$EXSET^IBEFUNC($P(IBX,U,14),660,12),1,4),?62,$$EXSET^IBEFUNC($P(IBY,U,3),660,62),?70,$J(+$P(IBX,U,16),9,2)
+ Q
+ ;
+PIN(P660,P6611) ; given Prosthetic record (#660) or PSAS HCPCS (#661.1) return Item Name
+ ; returns PSAS HCPSC ptr (661.1) ^ SHORT DESCRIPTION (661.1, .02) ^ HCPCS (661.1, .01)
+ N IBX,IBY S IBY=""
+ I +$G(P660) S P6611=+$P($G(^RMPR(660,+P660,1)),U,4)
+ I +$G(P6611) S IBX=$G(^RMPR(661.1,+P6611,0)) I IBX'="" S IBY=P6611_U_$P(IBX,U,2)_U_$P(IBX,U,1)
+PIN(PITEM) ;given the pros item IFN (661 ptr) returns name for printing (661,.01^441,.05)
+ N IBX,IBY S IBY="" I +$G(PITEM) S IBX=+$G(^RMPR(661,+PITEM,0)) I +IBX S IBY=IBX_U_$$DESCR^PRCPUX1(0,+IBX)
  Q IBY
+ ;
+PINB(P3625) ; given the bill prosthetics item (#362.5) return Item Name (.05)
+ N IBY S IBY=$P($G(^IBA(362.5,+$G(P3625),0)),U,5)
+ Q IBY
+ ;
+BILL(IBIFN) ; get bill data: returns DFN ^ Statement Covers From ^ Statement Covers To
+ N IBX,IBY S IBIFN=+$G(IBIFN) S IBX=$G(^DGCR(399,IBIFN,0)),IBY=$P(IBX,U,2)
+ S IBX=$G(^DGCR(399,IBIFN,"U")),$P(IBY,U,2)=+IBX,$P(IBY,U,3)=+$P(IBX,U,2)
+ Q IBY
+ ;
+ONBILLPI(IBIFN,PIFN) ; return Bill Item ptr (#362.5) if the Prosthetics Item (#660) is already assigned to the bill
+ ; input:  PIFN = Patient Prosthetics Item (ptr to 660)
+ ; output: BIFN = Bill Prosthetics Item (ptr to 362.5) or null if not found
+ N IBC,IBX,IBY,BIFN S IBY="" S IBC="AIFN"_$G(IBIFN)
+ S IBX=0 F  S IBX=$O(^IBA(362.5,IBC,IBX)) Q:'IBX  S BIFN=0 F  S BIFN=$O(^IBA(362.5,IBC,IBX,BIFN)) Q:'BIFN  D
+ . I +$G(PIFN),$P($G(^IBA(362.5,BIFN,0)),U,4)=PIFN S IBY=BIFN
+BILL(IBIFN) ; display all existing prescription refills (52) for a patient and date range
+ ; (call is a short cut to calling rxdisp if have bill number)
+ N IBX,IBY S IBX=$G(^DGCR(399,+$G(IBIFN),0)),IBY=$P(IBX,U,2)
+ S IBX=$G(^DGCR(399,+IBIFN,"U")),$P(IBY,U,2)=+IBX,$P(IBY,U,3)=+$P(IBX,U,2)
  Q IBY
+ ;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC61.m

-              r628
+              r636
 IBCSC61 ;ALB/MJB - MCCR SCREEN UTILITY ;20 JUN 88 10:58
  ;;2.0;INTEGRATED BILLING;**52,80,106,51,210,230,309,389**;21-MAR-94;Build 6
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**52,80,106,51,210,230,309**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
  ;MAP TO IBCSC61
 …
  .K ^TMP($J,"IBDRUG")
  .Q
  I $G(TYPE)=5,+$G(ITEM) S IBNAME=$P($G(^IBA(362.5,+ITEM,0)),U,5)
+ I $G(TYPE)=5,+$G(ITEM) S IBNAME=$P($$PIN^IBCSC5B(+$P($G(^IBA(362.5,+ITEM,0)),U,3)),U,2)
  I $G(TYPE)=6,+$G(ITEM) S IBNAME=$P($$DRG^IBACSV(+ITEM),U,1)
  I $G(TYPE)=9,+$G(ITEM) S IBNAME=$P($G(^IBA(363.21,+ITEM,0)),U,1)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC8H.m

-              r628
+              r636
 IBCSC8H ;ALB/ARH - MCCR SCREEN 8 (BILL SPECIFIC INFO) CMS-1500 ;4/21/92
  ;;2.0;INTEGRATED BILLING;**51,137,207,210,232,155,320,343,349,371**;21-MAR-94;Build 57
+ ;;2.0;INTEGRATED BILLING;**51,137,207,210,232,155,320,343,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ; CMS-1500 screen 8
 …
+ ;
 EN N I,IB,Y,Z
  D ^IBCSCU S IBSR=8,IBSR1="H",IBV1="00000000" S:IBV IBV1="11111111" F I="U","U1","UF2","UF3","U2","M","TX",0,"U3" S IB(I)=$G(^DGCR(399,IBIFN,I))
+ D ^IBCSCU S IBSR=8,IBSR1="H",IBV1="0000000" S:IBV IBV1="1111111" F I="U","U1","UF2","UF3","U2","M","TX",0,"U3" S IB(I)=$G(^DGCR(399,IBIFN,I))
  N IBZ,IBPRV,IBDATE,IBREQ,IBMRASEC,IBZ1
+ ;
 …
+ ;
  S Z=5,IBW=1 X IBWW
- W " Chiropractic Data  : " S Y=$P(IB("U3"),U,5) X ^DD("DD") W $S(Y'="":"INITIAL TREATMENT ON "_Y,1:IBUN)
+ ;
- S Z=6,IBW=1 X IBWW
  W " Form Locator 19    : " S IBZ=$P($G(^DGCR(399,IBIFN,"UF31")),U,3) W $S(IBZ'="":IBZ,1:IBUN)
  I $P(IB("U2"),U,14)'="" W !,?4,"Homebound          : ",$$EXPAND^IBTRE(399,236,$P(IB("U2"),U,14))
 …
  I $P(IB("U2"),U,16)'="" W !,?4,"Spec Prog Indicator: " S IBZ=$$EXPAND^IBTRE(399,238,$P(IB("U2"),U,16)) W $S(IBZ'="":IBZ,$$WNRBILL^IBEFUNC(IBIFN):"31",1:"")
+ ;
  S Z=7,IBW=1 X IBWW
+ S Z=6,IBW=1 X IBWW
  S IBREQ=+$$REQMRA^IBEFUNC(IBIFN) S:IBREQ IBREQ=1
  S IBMRASEC=$$MRASEC^IBCEF4(IBIFN)
 …
  W $S(IBZ'=""&($P(IB("TX"),U,8+IBREQ)'=""):IBZ,'$$TXMT^IBCEF4(IBIFN):"[NOT APPLICABLE - NOT TRANSMITTABLE]",IBREQ:"NO FORCED PRINT",1:IBZ)
+ ;
  S Z=8,IBW=1 X IBWW
+ S Z=7,IBW=1 X IBWW
  W " Provider ID Maint  : (Edit Provider ID information)",!
  G ^IBCSCP

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSCE.m

-              r628
+              r636
 IBCSCE ;ALB/MRL,MJB - MCCR SCREEN EDITS ;07 JUN 88 14:35
  ;;2.0;INTEGRATED BILLING;**52,80,91,106,51,137,236,245,287,349,371**;21-MAR-94;Build 57
+ ;;2.0;INTEGRATED BILLING;**52,80,91,106,51,137,236,245,287,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
  I (IBDR20["45")!(IBDR20["56") D ^IBCSC5B G ENQ
  I (IBDR20["66")!(IBDR20["76") D EDIT^IBCRBE(IBIFN) D ASKCMB^IBCU65(IBIFN) G ENQ
- I IBDR20["85",$$FT^IBCEF(IBIFN)=2 D ^IBCSC8A G ENQ ; chiropractic data
  I IBDR20["84",$$FT^IBCEF(IBIFN)=3 D EN1^IBCEP6 G ENQ   ;UB-04
  I IBDR20["88",$$FT^IBCEF(IBIFN)=2 D EN1^IBCEP6 G ENQ   ;CMS-1500
+ I IBDR20["87",$$FT^IBCEF(IBIFN)=2 D EN1^IBCEP6 G ENQ   ;CMS-1500
  F Q=1:1:9 I IBDR20[("9"_Q) D EDIT^IBCSC9 G ENQ
 TMPL N IBFLIAE S IBFLIAE=1 ;to invoke EN^DGREGAED from [IB SCREEN1]

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSCH.m

-              r628
+              r636
 IBCSCH ;ALB/MJB - MCCR HELP ROUTINE ;03 JUN 88 15:25
  ;;2.0;INTEGRATED BILLING;**52,80,106,124,138,51,148,137,161,245,232,287,348,349,374,371,395**;21-MAR-94;Build 3
+ ;;2.0;INTEGRATED BILLING;**52,80,106,124,138,51,148,137,161,245,232,287,348,349,374**;21-MAR-94;Build 16
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
  . I $G(IBSCNNZ)="?MRA",$$MCRONBIL^IBEFUNC(IBIFN),$T(SCR^IBCEMVU)'="" S IBQ=1 D SCR^IBCEMVU(IBIFN) Q
  . I $G(IBSCNNZ)="?ID" S IBQ=1 D DISPID^IBCEF74(IBIFN) Q
- . I $G(IBSCNNZ)="?RX" S IBQ=1 D DISPRX^IBCSCH1(IBIFN) Q
  . Q
+ ;
 …
  I $$MCRONBIL^IBEFUNC(IBIFN) W !?5,"Enter '?MRA' to view Medicare Remittance Advice EOB's on file."
  W !,?5,"Enter '?ID' to view all IDs to be electronically transmitted on this claim."
- W !,?5,"Enter '?RX' to view all prescriptions on this claim."
+ ;
  I +IBSR'=9 S Z="DATA GROUPS ON SCREEN "_+IBSR W ! X IBWW D @(IBSR1_IBSR) D W
 …
 S X="Locally defined fields" Q
 S X="Bill Remark, ICN/DCN's, Tx Auth. Code, Admit Diagnosis/Source ^Providers^Force to Print^Provider ID Maintenance^Other Facility (VA/non)" Q
 H8 S X="Period Unable to Work^Admit Dx, ICN/DCN, Tx/Prior Auth. Code^Providers^Non-VA Facility^Chiropractic Data^Form Locator 19^Force to Print^Provider ID Maintenance" Q
+H8 S X="Period Unable to Work^Admit Dx, ICN/DCN, Tx/Prior Auth. Code^Providers^Non-VA Facility^Form Locator 19^Force to Print" Q
 PAR S X="Fed Tax #, BC/BS #, MAS Svc Pointer^Bill Signer, Billing Supervisor^Security Parameters, Outpatient CPT parameters ^Remarks, Mailgroups^Agent Cashier Address/Phone" Q
 S N C,I,Z,J W !! S Z="AVAILABLE SCREENS" X IBWW

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSCH1.m

-              r628
+              r636
 IBCSCH1 ;ALB/MRL - BILLING HELPS (CONTINUED) ; 01 JUN 88 12:00
  ;;2.0;INTEGRATED BILLING;**106,125,51,245,266,395**;21-MAR-94;Build 3
+ ;;2.0;INTEGRATED BILLING;**106,125,51,245,266**;21-MAR-94
  ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
 …
  N DIR,DUOUT,DTOUT,DIRUT,IBX,X,Y S IBX=0,DIR(0)="E" D ^DIR K DIR I $D(DIRUT) S IBX=1
  Q IBX
+ ;
-DISPRX(IBIFN) ; display prescriptions
- N IBHDR,IBHDR1,IBX,IBZ,IBRXL,IBNPI,IBRX,IBQ,IBORG
- S IBQ=0
+ ;
- I '$O(^IBA(362.4,"AIFN"_IBIFN,0)) W !!?5,"No Prescriptions Entered!",! D PAUSE^VALM1 Q
+ ;
- ; get NPIs
- S IBX=$$RXSITE^IBCEF73A(IBIFN,.IBRXL)
+ ;
- S IBHDR="W @IOF,!,""Prescriptions Assigned to this Bill"" X IBHDR1"
- S IBHDR1="W !,""--------------------------------------------------------------------------------"" "
+ ;
- X IBHDR
- S IBRX=0 F  S IBRX=$O(^IBA(362.4,"AIFN"_IBIFN,IBRX)) Q:'IBRX!(IBQ)  S IBX=0 F  S IBX=$O(^IBA(362.4,"AIFN"_IBIFN,IBRX,IBX)) Q:'IBX!(IBQ)  D
- . S IBZ=$G(^IBA(362.4,IBX,0))
- . W !?5,"RX #: ",$P(IBZ,"^")
- . W ?50,"DATE: ",$$FMTE^XLFDT($P(IBZ,"^",3))
- . W !?5,"DRUG: ",$$EXTERNAL^DILFD(362.4,.04,"",$P(IBZ,"^",4))
- . W ?50,"NDC: ",$P(IBZ,"^",8)
- . W !?5,"DAYS SUPPLY: ",$P(IBZ,"^",6)
- . W ?50,"QUANTITY: ",$P(IBZ,"^",7)
- . S IBORG=$G(IBRXL(+$P(IBZ,"^",5),+$P(IBZ,"^",3)))
- . ; ia #4532
- . S IBNPI=$S(IBORG:$P($$NPI^XUSNPI("Organization_ID",IBORG),U),1:"")
- . W !?5,"NPI INSTITUTION: ",$S(IBORG:$$EXTERNAL^DILFD(350.9,.02,"",IBORG),1:"")
- . W ?50,"RX NPI: ",$S(IBNPI>0:IBNPI,1:"")
- . W !?5,"PROVIDER: ",$S($P(IBZ,"^",5):$$RXAPI1^IBNCPUT1($P(IBZ,"^",5),4),1:""),!
- . I $Y+7>IOSL S IBQ=$$PAUSE(0)
- D PAUSE^VALM1
+ ;
+ Q
+ ;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCU4.m

-              r628
+              r636
 IBCU4 ;ALB/AAS - BILLING UTILITY ROUTINE (CONTINUED) ;12-FEB-90
  ;;2.0;INTEGRATED BILLING;**109,122,137,245,349,371**;21-MAR-94;Build 57
+IBCU4 ;ALB/AAS - BILLING UTILITY ROUTINE (CONTINUED) ; 12-FEB-90
+ ;;2.0;INTEGRATED BILLING;**109,122,137,245,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
+ Q
+ ;
+CHDAT ; Input transform for chiropractics-related dates (399/245,246,247)
+ ; Make sure that date entered is not after end date of the bill
+ Q:'$D(X)
+ N IBX,Y
+ S IBX=$P($G(^DGCR(399,+DA,"U")),U,2)
+ I IBX="" W !?4,*7,"No end date of the bill on file - can't enter chiropractics-related dates " K X Q
+ I X>+IBX S Y=IBX D DD^%DT W !,?4,*7,"This date can not be after the end date of the claim ("_Y_") " K X Q
+ Q
+ ;
+ ;
 TO ;151 pseudo input x-form

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCU7.m

-              r628
+              r636
 IBCU7 ;ALB/AAS - INTERCEPT SCREEN INPUT OF PROCEDURE CODES ;29-OCT-91
  ;;2.0;INTEGRATED BILLING;**62,52,106,125,51,137,210,245,228,260,348,371**;21-MAR-94;Build 57
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**62,52,106,125,51,137,210,245,228,260,348**;21-MAR-94;Build 5
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
  ;MAP TO DGCRU7
 …
  D ^DIR K DIR
  I Y'=1 S IBOK=0 G ADDTNLQ
  S DR="W !,""  <<EPSDT>>"";50.07;W !!,""  <<HOSPICE>>"";50.03"
+ S DR="W !,""  <<EPSDT>>"";50.07;W !!,""  <<HOSPICE>>"";50.03;W !!,""  <<CHIROPRACTIC>>"";50.04;50.02;50.05;50.06"
  D ^DIE
  W !

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCVA0.m

-              r628
+              r636
 IBCVA0 ;ALB/MJB - SET MCCR VARIABLES CONT.  ;04 AUG 88 03:02
  ;;2.0;INTEGRATED BILLING;**52,361,371**;21-MAR-94;Build 57
+ ;;2.0;INTEGRATED BILLING;**52,361**;21-MAR-94;Build 9
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
  E  S IBISEX(I)=$P($G(^DPT(DFN,.312,+$P($G(^DGCR(399,IBIFN,"M")),U,I+11),3)),U,12) ; *361 replaces old calculation of insured's sex
  S IBISEX(I)=$S(IBISEX(I)="M":"MALE",IBISEX(I)="F":"FEMALE",1:"UNSPECIFIED")
+ S IBIRN(I)=$P(IBDD(I,0),U,16)
+ S IBIR(I)=$$EXTERNAL^DILFD(2.312,16,,IBIRN(I))
+ S IBIRN(I)=$P(IBDD(I,0),U,16),IBIR(I)=$S(IBIRN(I)="01":"PATIENT",IBIRN(I)="02":"SPOUSE",IBIRN(I)="03":"CHILD",IBIRN(I)="08":"EMPLOYEE",IBIRN(I)="11":"ORGAN DONOR",IBIRN(I)="18":"PARENT",IBIRN(I)=15:"PLANTIFF",1:"UNKNOWN")
+ I IBIR(I)="UNKNOWN" S IBIR(I)=$S('$D(IBDD(I,0)):"UNKNOWN",$P(IBDD(I,0),U,6)="v":"PATIENT",$P(IBDD(I,0),U,6)="s":"SPOUSE",1:"UNKNOWN")
+ ;S IBIUTL(I)=IBDD(I,0)_"^"_IBISEX(I)_"^"_IBIRN(I)
+ Q
 ADDR ;SET ADDRESS

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCVA1.m

r628	r636
1	1	IBCVA1 ;ALB/MJB - SET MCCR VARIABLES CONT. ;09 JUN 88 14:49
2		;;2.0;INTEGRATED BILLING;52,80,109,51,137,210,349~~,371;21-MAR-94;Build 57~~
	2	;;2.0;INTEGRATED BILLING;52,80,109,51,137,210,349;21-MAR-94;Build 46
3	3	;;Per VHA Directive 2004-038, this routine should not be modified.
4	4	;
…	…
89	89	S IBX=0 F S IBX=$O(^DGCR(399,IBIFN,"CV",IBX)) Q:'IBX S IBY=$G(^DGCR(399,IBIFN,"CV",IBX,0)) I +IBY D
90	90	. S IBVC=IBVC+1,IBZ=$G(^DGCR(399.1,+IBY,0)) Q:IBZ=""
91		. S IBVC(+IBY)=$P(IBZ,U,2)_U_$P(IBZ,U,1)_U_$S(~~$P(IBY,U,2)="":"",~~+$P(IBZ,U,12):$J($P(IBY,U,2),0,2),1:$P(IBY,U,2))_U_$P(IBZ,U,12)
	91	. S IBVC(+IBY)=$P(IBZ,U,2)_U_$P(IBZ,U,1)_U_$S(+$P(IBZ,U,12):$J($P(IBY,U,2),0,2),1:$P(IBY,U,2))_U_$P(IBZ,U,12)
92	92	Q
93	93	;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJDB1.m

r628	r636
1	1	IBJDB1 ;ALB/CPM - BILLING LAG TIME REPORT ; 27-DEC-96
2		;;2.0;INTEGRATED BILLING;69,80,100,118~~,165~~;21-MAR-94
	2	;;2.0;INTEGRATED BILLING;69,80,100,118;21-MAR-94
3	3	;
4	4	EN ; - Option entry point.
…	…
78	78	;
79	79	D ^%ZISC
80		ENQ1 K IB,IBBDT,IB~~BN,IBEDT,IBCK,IBN,IBN0,IBRPT,IBPAG,IBQ,IBRUN,IBX,IBX1,IBX2~~
81		K IB~~X3,IBAUTH,IBDAT,IBDFN,IBNU,IBPTF,IBPOL,IBPOL1,IBTY,IBS,IBSEL,IBSEL1~~
82		K IB~~CT,IB~~DIV,IBSORT,IBTL,IBCHK,IBDCHK,DFN,POP,VAUTD,ZTDESC,ZTRTN,ZTSAVE
83		K ~~IBDR,IBH,~~DIROUT,DTOUT,DUOUT,DIRUT,%,%ZIS,D,X,X1,X2,Y,Y1,Z,Z1,Z2,Z3
	80	ENQ1 K IB,IBBDT,IBEDT,IBCK,IBN,IBN0,IBRPT,IBPAG,IBQ,IBRUN,IBX,IBX1,IBX2,IBX3
	81	K IBAUTH,IBDAT,IBDFN,IBNU,IBPTF,IBPOL,IBPOL1,IBTY,IBS,IBSEL,IBSEL1,IBCT
	82	K IBDIV,IBSORT,IBTL,IBCHK,IBDCHK,DFN,POP,VAUTD,ZTDESC,ZTRTN,ZTSAVE
	83	K DIROUT,DTOUT,DUOUT,DIRUT,%,%ZIS,D,X,X1,X2,Y,Y1,Z,Z1,Z2,Z3
84	84	Q
85	85	;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJDB11.m

-              r628
+              r636
 IBJDB11 ;ALB/CPM - BILLING LAG TIME REPORT (COMPILE) ; 27-DEC-96
  ;;2.0;INTEGRATED BILLING;**69,100,118,165**;21-MAR-94
+ ;;2.0;INTEGRATED BILLING;**69,100,118**;21-MAR-94
+ ;
 EN ; - Entry point from IBJDB1.
 …
  .S IBTY=$S($P(IBN0,U,5)<3:"IN",1:"OP") ; Inpatient or outpatient claim?
  .;
+ .;- Get date PTF transmitted.
+ .S IBPTF="" I IBTY="IN" S IBPTF=$$PTF($P(IBN0,U,8)) Q:'IBPTF
+ .; - Get most recent date PTF transmitted.
+ .I IBTY="IN" D  Q:'IBPTF!('IBPTF&($P(IBAUTH,U,2)))
+ ..S IBPTF=$P(IBN0,U,8) I 'IBPTF Q
+ ..S IBPTF=$O(^DGP(45.83,"C",IBPTF,9999999),-1)\1 I IBPTF Q
+ ..S IBPTF=$P($G(^DGP(45.83,IBPTF,0)),U,2)\1
  .;
  .; - Get other claim info and build date line.
 …
  ..; - Get most recent check out date that has not been marked as non
  ..;   billable by Claims Tracking; quit if there isn't one.
+ ..I IBTY="OP" D  K IBCL,IBCL1 Q:'IBCHK
+ ...D CL(IBN) ;GET LIST OF CLINICS FOR THIS BILL
+ ..I IBTY="OP" D  Q:'IBCHK
  ...S IBCHK=0,IBX1=IBX-.0001
  ...F  S IBX1=$O(^SCE("ADFN",DFN,IBX1)) Q:'IBX1!((IBX1\1)>IBX)  D
  ....S IBX2=0 F  S IBX2=$O(^SCE("ADFN",DFN,IBX1,IBX2)) Q:'IBX2  D
- .....;
- .....;CHECK TO SEE IF CLINICS MATCH
- .....S IBCL1=+$P($G(^SCE(IBX2,0)),U,4) Q:'$D(IBCL(IBCL1))
  .....I $P($G(^IBT(356,+$O(^IBT(356,"ASCE",IBX2,0)),0)),U,19) Q
+ .....S IBX3=$P($G(^SCE(IBX2,0)),U,7)\1 I IBX3,IBX3'>$P(IBAUTH,U,2)  D
+ ...... S:IBX3>IBCHK IBCHK=IBX3 Q
+ .....S IBX3=$P($G(^SCE(IBX2,0)),U,7)\1 I IBX3 S IBCHK=IBX3
  ..;
  ..S X=$S(IBTY="IN":IBX1_U_+IBPTF,1:IBX_U_IBCHK)_U_IBDAT
+ ..S X=$S(IBTY="IN":IBX1_U_IBPTF,1:IBX_U_IBCHK)_U_IBDAT
  ..S IBPOL1=$S(IBPOL>+X:1,1:0) ; Policy found after treatment.
  ..;
 …
  ..F Y=1:1 S Z=$P(IBSEL1,",",Y) Q:'Z  D
  ...I IBRPT="D" D
+ ....S IBBN=$P(IBN0,U) S:IBPOL1 IBBN=IBBN_"*"
+ ....S Y(Z)=IBBN_U_Y(Z),Y1(Z)=$G(Y1(Z))+1
+ ....S Y(Z)=$P(IBN0,U)_U_Y(Z)_U_$S(IBPOL1:"*",1:""),Y1(Z)=$G(Y1(Z))+1
  ....S ^TMP("IBJDB1",$J,IBDIV,IBTY,Z,$P(IBDFN,U)_"@@"_$P(IBDFN,U,9),Y1(Z))=Y(Z)
  ...E  S IBCT(IBDIV,IBTY,Z)=IBCT(IBDIV,IBTY,Z)+1,IBTL(IBDIV,IBTY,Z)=IBTL(IBDIV,IBTY,Z)+Y(Z)
 …
+ ;
 FP ; - Get first payment date, if available.
  I '$P($G(^PRCA(430,IBN,7)),U,7) G DC ; No payments made.
+ I '$P($G(^PRCA(430,IBN,7)),U,7) G CL ; No payments made.
  S (IBPAY,IBT)=0 F  S IBT=$O(^PRCA(433,"C",IBN,IBT)) Q:'IBT  D  Q:IBPAY
  .S IBT0=$G(^PRCA(433,IBT,0)),IBT1=$G(^(1))
 …
  .S X=$S(+IBT1:+IBT1,1:$P(IBT1,U,9)\1),$P(VAL,U,4)=X,IBPAY=1
+ ;
 DC ; - Get date AR closed.
+CL ; - Get date AR closed.
  S X=$$CLO^PRCAFN(IBN) I X>0 S $P(VAL,U,5)=X
+ ;
 …
  I IBSEL[(","_X_","),X1'<IBBDT,X1'>IBEDT S X2=1
 DLQ Q X2
+ ;
+ ;
-PTF(X) ; - Get most recent PTF transmission date.
- ;    Input: X=IEN of PTF file entry.
- ;   Output: Y=PTF date.
- N I,K,Y
- S Y=0 G:'$O(^DGP(45.83,"C",+X,0)) PTFQ
- S I=0 F  S I=$O(^DGP(45.83,"C",X,I)) Q:'I  D
- .S J=$P($G(^DGP(45.83,I,0)),U,2)\1  Q:J>$P(IBAUTH,U,2)  S:J K(J)=""
- S I=0 F  S I=$O(K(I)) Q:'I  S Y=I
+ ;
-PTFQ Q Y
+ ;
-CL(IBN) ; - Get the clinics for bill.
- N I,J K IBCL ; IBCL=Bill clinic array.
- S I=0 F  S I=$O(^DGCR(399,IBN,"CP",I)) Q:I=""  D
- .S J=$P($G(^DGCR(399,IBN,"CP",I,0)),U,7) S:J IBCL(J)=""
+ Q

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJPS.m

-              r628
+              r636
 IBJPS ;ALB/MAF,ARH - IBSP IB SITE PARAMETER SCREEN ;22-DEC-1995
  ;;2.0;INTEGRATED BILLING;**39,52,70,115,143,51,137,161,155,320,348,349,377**;21-MAR-94;Build 23
+ ;;2.0;INTEGRATED BILLING;**39,52,70,115,143,51,137,161,155,320,348,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
 ;;1.33;1.32;1.31;1.27
 ;;1.29;1.3;1.18;1.28
 ;;1.01;1.02;1.05
+;;1.01;1.02;1.05;1.04
 ;;2.12;2.1;2.02;2.03;2.04;2.05;2.06;2.01
 ;;2.08;2.09

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJPS2.m

-              r628
+              r636
 IBJPS2 ;ALB/MAF,ARH - IBSP IB SITE PARAMETER BUILD (cont) ;22-DEC-1995
  ;;2.0;INTEGRATED BILLING;**39,52,115,143,51,137,161,155,320,348,349,377**;21-MAR-94;Build 23
+ ;;2.0;INTEGRATED BILLING;**39,52,115,143,51,137,161,155,320,348,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
  D LEFT(2)
  S IBLN=$$SET("Federal Tax #",$P(IBPD1,U,5),IBLN,IBLR,IBSEL)
+ ;
+ D RIGHT(3,"","")
+ S IBLN=$$SET("Remark on Each Bill",$P(IBPD1,U,4),IBLN,IBLR,IBSEL)
+ ;
  D RIGHT(3,1,1) ; - Remittance/Agent Cashier Address

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTA1.m

-              r628
+              r636
 IBJTA1 ;ALB/ARH - TPI ACTIONS ;2/14/95
  ;;2.0;INTEGRATED BILLING;**39,137,377**;21-MAR-94;Build 23
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**39,137**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
 CP ; -- IBJT CHANGE PATIENT action: change patient, only available on AL screen
 …
  ;     IBARCOMM set to indicate AR Profile screen needs to be rebuilt when it is reentered
  ;     will cause the AR screen to be rebuilt including the new information if the AR screen is already open
  N AUTHDT,MRADT,STATUS,VALMQUIT,DIR
+ N VALMQUIT,DIR
  D FULL^VALM1
+ S STATUS=$P($G(^DGCR(399,IBIFN,0)),U,13)
+ S AUTHDT=$P($G(^DGCR(399,IBIFN,"S")),U,10)
+ S MRADT=$P($G(^DGCR(399,IBIFN,"S")),U,7)
+ ; if claim status is "NOT REVIEWED" or claim status is "CANCELLED" with neither MRA request date
+ ; nor Authorization date present, display an error and bail out.
+ I STATUS=1!(STATUS=7&(MRADT="")&(AUTHDT="")) D  G ARCAQ
+ .S DIR(0)="EA",DIR("A",1)="A comment can not be added for an incomplete or cancelled while incomplete claim.",DIR("A")="Press RETURN to continue: " D ^DIR K DIR
+ ; if claim status is "REQUEST MRA" or claim status is "CANCELLED" with MRA request date present,
+ ; but no Authorization date, enter MRA comments.
+ I STATUS=2!(STATUS=7&(MRADT'="")&(AUTHDT="")) D:$G(IBIFN) CMNT^IBCECOB6 G ARCAR
+ ; otherwise, enter AR comments.
+ I $P($G(^DGCR(399,IBIFN,0)),U,13)=2 D  G ARCAQ
+ . S DIR(0)="EA",DIR("A",1)="A/R comments cannot be added for a bill awaiting an MRA request",DIR("A")="Press RETURN to continue: " D ^DIR K DIR
  D ADJUST^RCJIBFN3(IBIFN)
  I $D(^TMP("IBJTTA",$J)) S IBARCOMM=1
+ K ^TMP("IBJTTC",$J)
+ARCAR ; rebuild comments screen
+ D BLD^IBJTTC,HDR^IBJTTC
+ K ^TMP("IBJTTC",$J) D BLD^IBJTTC,HDR^IBJTTC
 ARCAQ S VALMBCK="R",VALMBG=1
+ Q

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTBA.m

-              r628
+              r636
 IBJTBA ;ALB/ARH - TPI BILL CHARGE INFO SCREEN ;01-MAR-1995
  ;;2.0;INTEGRATED BILLING;**39,80,51,137,135,309,349,389**;21-MAR-94;Build 6
+ ;;2.0;INTEGRATED BILLING;**39,80,51,137,135,309,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
  D SET^IBCSC5B(IBIFN,.IBARRAY)
  I $D(IBARRAY) D
  . S (Z,Z0)=0 F  S Z0=$O(IBARRAY(Z0)) Q:Z0=""  S Z1=0 F  S Z1=$O(IBARRAY(Z0,Z1)) Q:'Z1  S Z=Z+1,IBXDATA(Z)=$$DAT1^IBOUTL(Z0)_U_$E($$PINB^IBCSC5B(+IBARRAY(Z0,Z1)),1,39)
+ . S (Z,Z0)=0 F  S Z0=$O(IBARRAY(Z0)) Q:Z0=""  S Z1=0 F  S Z1=$O(IBARRAY(Z0,Z1)) Q:'Z1  S Z=Z+1,IBXDATA(Z)=$$DAT1^IBOUTL(Z0)_U_$E($P($$PIN^IBCSC5B(Z1),U,2),1,39)
  S IBD=$$SET("",IBLN)
  S IBD="PROSTHETIC REFILLS: (For TPJI display only)"

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTCA2.m

-              r628
+              r636
 IBJTCA2 ;ALB/ARH - TPI CLAIMS INFO BUILD (CONT) ;16-FEB-1995
  ;;2.0;INTEGRATED BILLING;**39,80,155,320**;21-MAR-94
+IBJTCA2 ;ALB/ARH - TPI CLAIMS INFO BUILD (CONT) ;7:39 PM  30 Jan 2008
+ ;;2.0;INTEGRATED BILLING;**39,80,155,320,VWEHR1**;WorldVistA 30-Jan-08
  ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
 CONT ; Continuation of Claim Information Screen Build
 …
  I +$P(IBDS,U,17) S IBT="Cancelled: ",IBD=$$EXT(IBDS,17,18) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+ ;
  ; Patch 320 - added bill cloning history to TPJI report.
+ ; Patch 320 - added bill cloning history to TPJI report.
  N IBCCR,IBCURR,IBNEXT,IBBCH,IBINDENT
  S IBINDENT=0
 …
  ; now go backwards for claim cloning history all the way back
  S IBBCH=IBCURR
+ F  S IBBCH=$Q(@IBBCH,-1) Q:IBBCH=""  D
+ ;
+ ;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
+ ;
+ ;F  S IBBCH=$Q(@IBBCH,-1) Q:IBBCH=""  D
+ F  S IBBCH=$$Q^VWUTIL($NA(@IBBCH),-1) Q:IBBCH=""  D
+ . ;
+ . ;END CHANGE
+ . ;
  . N IBX S IBX=@IBBCH
  . S IBT="Copied: " I IBINDENT S IBT="                  "_IBT

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTRA1.m

-              r628
+              r636
 IBJTRA1 ;ALB/AAS,ARH - TPI CT INSURANCE COMMUNICATIONS BUILD ; 4/1/95
  ;;2.0;INTEGRATED BILLING;**39,91,347,389**;21-MAR-94;Build 6
+ ;;2.0;INTEGRATED BILLING;**39,91,347**;21-MAR-94;Build 24
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
 …
  S X=$$EXSET^IBJU1(IBTYP,356,.18)
  I IBTYP=2 S X=X_" of "_$P($G(^DIC(40.7,+$$SCE^IBSDU(+$P(IBTRND,U,4),3),0)),U,1)
  I IBTYP=3 S X=X_" of "_$P($$PIN^IBCSC5B(+$P(IBTRND,U,9)),U,2)
+ I IBTYP=3 S Y=+$P($G(^RMPR(660,+$P(IBTRND,U,9),0)),U,6),X=X_" of "_$$EXSET^IBJU1(Y,660,4)
  I IBTYP=4 S X=X_" of "_$$FILE^IBRXUTL(+$P(IBTRND,U,8),.01)
  S X=X_" on "_$$DAT1^IBOUTL($P(IBTRND,U,6),"2P")

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTTC.m

-              r628
+              r636
 IBJTTC ;ALB/ARH - TPI AR COMMENT HISTORY ; 06-MAR-1995
  ;;2.0;INTEGRATED BILLING;**39,377**;21-MAR-94;Build 23
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;Version 2.0 ; INTEGRATED BILLING ;**39**; 21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
  ; AR Profile of Comments:  This screen prints the following Comments:
 …
+ ;
 BLD ;
  N CMLN,CMSTR,X,IBCNT,IBZ,IB0,IBI,IBX,IBD,IBDATE,IBDUZ,IBRCT5,IBLN,IBSTR,IBK,IBJ,DIWL,DIWR,DIWF,COM
+ N X,IBCNT,IBI,IBX,IBD,IBRCT5,IBLN,IBSTR,IBK,IBJ,DIWL,DIWR,DIWF,COM
+ ;
  S VALMCNT=0,IBLN=0
 …
  . K ^UTILITY($J,"W")
  K ^TMP("RCJIB",$J),^UTILITY($J,"W")
- ; MRA comments
- ; check if we have any comments to display
- I $D(^DGCR(399,IBIFN,"TXC","B")) D
- .S IBLN=$$SET("",IBLN)
- .S IBSTR="",IBSTR=$$SETLN("MRA REQUEST CLAIM COMMENTS",IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN)
- .S IBSTR="",IBSTR=$$SETLN("--------------------------",IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN)
- .; loop through all available comments
- .S IBDATE="" F  S IBDATE=$O(^DGCR(399,IBIFN,"TXC","B",IBDATE),-1) Q:IBDATE=""  D
- ..S IBZ=$O(^DGCR(399,IBIFN,"TXC","B",IBDATE,"")),IB0=^DGCR(399,IBIFN,"TXC",IBZ,0),IBDUZ=$P(IB0,U,2)
- ..S IBLN=$$SET("",IBLN)
- ..S IBSTR=""
- ..S IBSTR=$$SETLN($$FMTE^XLFDT(IBDATE,"2Z"),IBSTR,14,8)
- ..S IBSTR=$$SETLN($J("Entered by "_$$GET1^DIQ(200,IBDUZ,.01),54),IBSTR,25,54)
- ..S IBLN=$$SET(IBSTR,IBLN),IBSTR=""
- ..; loop through comment lines
- ..S CMLN=0 F  S CMLN=$O(^DGCR(399,IBIFN,"TXC",IBZ,1,CMLN)) Q:CMLN=""  D
- ...S X=^DGCR(399,IBIFN,"TXC",IBZ,1,CMLN,0) I X'="" S DIWL=1,DIWR=54,DIWF=""  D ^DIWP
- ...Q
- ..I $D(^UTILITY($J,"W")) S IBK=0 F  S IBK=$O(^UTILITY($J,"W",1,IBK)) Q:'IBK  D
- ...S CMSTR=$G(^UTILITY($J,"W",1,IBK,0)) S IBSTR=$$SETLN(CMSTR,IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN),IBSTR=""
- ...Q
- ..K ^UTILITY($J,"W")
- ..Q
- .D CLEAN^DILF
- .Q
+ ;
  I IBLN=0 S IBLN=$$SET("",IBLN),IBLN=$$SET("No Comment Transactions Exist For This Account.",IBLN)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBRFN3.m

-              r628
+              r636
 IBRFN3 ;ALB/ARH - PASS BILL/CLAIM TO AR ;3/18/96
  ;;2.0;INTEGRATED BILLING;**61,133,210,309,389**;21-MAR-94;Build 6
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**61,133,210,309**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
  ;  Returns information on the bill passed in,  all data returned in external format, for AR's RC project
 …
  .. S IBX=IBTMP(IBI,IBK)
  .. S IBJ=IBJ+1,ARRAY("PRD")=IBJ
  .. S ARRAY("PRD",IBJ)=$$PINB^IBCSC5B(+IBX)_U_IBI
+ .. S ARRAY("PRD",IBJ)=$P($$PIN^IBCSC5B(IBK),U,2)_U_IBI
+ ;
 CC ; condition related to employment, auto accident (place), other accident

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBRFN4.m

-              r628
+              r636
 IBRFN4 ;ALB/TMK - Supported functions for AR/IB DATA EXTRACT ;15-FEB-2005
  ;;2.0;INTEGRATED BILLING;**301,305,389**;21-MAR-94;Build 6
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**301,305**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
 IBAREXT(IBIFN,IBD) ; Returns data for claim IBIFN for IB/AR Extract
 …
  .. S IBX=IBTMP(IBI,IBK)
  .. S IBJ=IBJ+1
  .. S IBD("PRD",IBJ)=$$PINB^IBCSC5B(+IBX)_U_IBI_U_+IBTMP
+ .. S IBD("PRD",IBJ)=$P($$PIN^IBCSC5B(IBK),U,2)_U_IBI_U_+IBTMP
+ ;
  S Z=" ",IBD("IN")="",DFN=+$P(IB(0),U,2)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTOBI1.m

-              r628
+              r636
 IBTOBI1 ;ALB/AAS - CLAIMS TRACKING BILLING INFORMATION PRINT ;27-OCT-93
  ;;2.0;INTEGRATED BILLING;**276,377**;21-MAR-94;Build 23
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**276**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
 % ;
 …
  I ($Y+8)>IOSL D HDR^IBTOBI Q:IBQUIT
 BI1 W !,"  Billing Information "
  N IBDGCR,IBDGCRU1,IBDGCRU,IBAMNT,IBD,I,IBIFN,IBLN,IBECME
+ N IBDGCR,IBDGCRU1,IBDGCRU,IBAMNT,IBD,I,IBIFN,IBADD,IBECME
  S IBIFN=+$P(IBTRND,"^",11)
  S IBDGCR=$G(^DGCR(399,IBIFN,0)),IBDGCRU1=$G(^("U1")),IBDGCRU=$G(^("U"))
  S IBECME=$P($P($G(^DGCR(399,IBIFN,"M1")),U,8),";")
  S IBAMNT=$$BILLD^IBTRED1(IBTRN)
  S IBLN=0
  S IBLN=IBLN+1,IBD(IBLN,1)="  Initial Bill: "_$P(IBDGCR,U,1)
+ S IBADD=0
+ S IBD(1,1)="  Initial Bill: "_$P(IBDGCR,"^")
  I IBECME D
+ . S IBD(IBLN,1)=IBD(IBLN,1)_"e"
+ . S IBLN=IBLN+1,IBD(IBLN,1)="   ECME Number: "_IBECME
+ S IBLN=IBLN+1,IBD(IBLN,1)="   Bill Status: "_$E($$EXPAND^IBTRE(399,.13,$P(IBDGCR,U,13)),1,14)
+ S IBLN=IBLN+1,IBD(IBLN,1)=" Total Charges: $ "_$J($P(IBAMNT,"^"),8)
+ S IBLN=IBLN+1,IBD(IBLN,1)="   Amount Paid: $ "_$J($P(IBAMNT,"^",2),8)
+ . S IBADD=1
+ . S IBD(1,1)=IBD(1,1)_"e"
+ . S IBD(2,1)="   ECME Number: "_IBECME
+ S IBD(2+IBADD,1)="   Bill Status: "_$E($$EXPAND^IBTRE(399,.13,$P(IBDGCR,"^",13)),1,14)
+ S IBD(3+IBADD,1)=" Total Charges: $ "_$J($P(IBAMNT,"^"),8)
+ S IBD(4+IBADD,1)="   Amount Paid: $ "_$J($P(IBAMNT,"^",2),8)
+ ;
+ I $P(IBTRND,U,19) D
+ . S IBLN=IBLN+1,IBD(IBLN,1)="Reason Not Billable: "_$$EXPAND^IBTRE(356,.19,$P(IBTRND,U,19))
+ . S IBLN=IBLN+1,IBD(IBLN,1)="Additional Comment: "_$P(IBTRND1,U,8)
+ . Q
+ ;
+ I '$P(IBTRND,U,19),$L($P(IBTRND1,U,8))>0 S IBLN=IBLN+1,IBD(IBLN,1)="Additional Comment: "_$P(IBTRND1,U,8)
+ I $P(IBTRND,"^",19) S IBD(5,1)="Reason Not Billable: "_$$EXPAND^IBTRE(356,.19,$P(IBTRND,"^",19)),IBD(6,1)="Additional Comment: "_$P(IBTRND1,"^",8)
+ ;
  S IBD(1,2)="Estimated Recv (Pri): $ "_$J($P(IBTRND,"^",21),8)
 …
  S IBD(3,2)="Estimated Recv (ter): $ "_$J($P(IBTRND,"^",23),8)
  S IBD(4,2)="  Means Test Charges: $ "_$J($P(IBTRND,"^",28),8)
+ ;
+ I $L($P($G(^IBT(356,IBTRN,1)),U,8))>0 S IBD(5,1)="Additional Comment: "_$P($G(^IBT(356,IBTRN,1)),U,8)
  S I=0 F  S I=$O(IBD(I)) Q:'I  W !,$G(IBD(I,1)),?39,$E($G(IBD(I,2)),1,36)
  W:'IBQUIT !,?4,$TR($J(" ",IOM-8)," ","-")

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTOBI4.m

-              r628
+              r636
 IBTOBI4 ;ALB/AAS - CLAIMS TRACKING BILLING INFORMATION PRINT ;27-OCT-93
  ;;2.0;INTEGRATED BILLING;**91,125,51,210,266,389**;21-MAR-94;Build 6
+ ;;2.0;INTEGRATED BILLING;**91,125,51,210,266**;21-MAR-94
+ ;
 CLIN ; -- output clinical information
 …
 ; -- Visit region for prosthetics
  N IBDA,IBRMPR S IBDA=$P(IBTRND,"^",9) D PRODATA^IBTUTL1(IBDA)
  S IBD(2,1)="          Item: "_$P($$PIN^IBCSC5B(+IBDA),U,2)
+ S IBD(2,1)="          Item: "_$G(IBRMPR(660,+IBDA,4,"E"))
  S IBD(3,1)="   Description: "_$G(IBRMPR(660,+IBDA,24,"E"))
  S IBD(4,1)="      Quantity: "_$J($G(IBRMPR(660,+IBDA,5,"E")),4)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTRED01.m

-              r628
+              r636
 IBTRED01 ;ALB/AAS - EXPAND/EDIT CLAIMS TRACKING ENTRY - CONT; 01-JUL-1993
  ;;2.0;INTEGRATED BILLING;**389**;21-MAR-94;Build 6
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
 % I '$G(IBTRN)!($G(IORVON)="") G ^IBTRED
 …
 ; -- Visit region for prosthetics
  N IBDA,IBRMPR S IBDA=$P(IBTRND,"^",9) D PRODATA^IBTUTL1(IBDA)
  D SET^IBCNSP(START+2,OFFSET,"          Item: "_$P($$PIN^IBCSC5B(+IBDA),U,2))
+ D SET^IBCNSP(START+2,OFFSET,"          Item: "_$G(IBRMPR(660,+IBDA,4,"E")))
  D SET^IBCNSP(START+3,OFFSET,"   Description: "_$G(IBRMPR(660,+IBDA,24,"E")))
  D SET^IBCNSP(START+4,OFFSET,"      Quantity: "_$J($G(IBRMPR(660,+IBDA,5,"E")),$L($G(IBRMPR(660,+IBDA,14,"E")))))

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTRKR5.m

r628	r636
1	1	IBTRKR5 ;ALB/AAS - CLAIMS TRACKING - ADD/TRACK PROSTHETICS ;13-JAN-94
2		;;2.0;INTEGRATED BILLING;13,260,312,339~~,389;21-MAR-94;Build 6~~
	2	;;2.0;INTEGRATED BILLING;13,260,312,339;21-MAR-94;Build 2
3	3	;;Per VHA Directive 2004-038, this routine should not be modified.
4	4	;
…	…
82	82	;
83	83	S IBDATA=$G(^RMPR(660,+IBDA,0)) Q:IBDATA=""
84		S DFN=$P(IBDATA,"^",2) ~~Q:'DFN~~
	84	S DFN=$P(IBDATA,"^",2)
85	85	D CL^SDCO21(DFN,IBDT,"",.IBARR)
86	86	;
87	87	; -- checks copied from rmprbil v2.0 /feb 2, 1994
88	88	Q:'$D(^RMPR(660,+IBDA,"AM"))
89		Q:$P(^RMPR(660,+IBDA,0),U,9)=""!($P(^(0),U,12)="")!($P(^(0),U,14)="V")!($P(^(0),U,2)="")!($P(^(0),U,15)="*")
	89	Q:$P(^RMPR(660,+IBDA,0),U,9)=""!($P(^(0),U,12)="")!($P(^(0),U,6)="")!($P(^(0),U,14)="V")!($P(^(0),U,2)="")!($P(^(0),U,15)="*")
90	90	;Q:($P(^RMPR(660,+IBDA,"AM"),U,3)=2)!($P(^("AM"),U,3)=3)
91	91	;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXA.m

r628	r636
1		IBXA ; DRIVER FOR COMPILED XREFS FOR FILE #350 ; ~~05/25~~/06
	1	IBXA ; DRIVER FOR COMPILED XREFS FOR FILE #350 ; 10/08/06
2	2	;
3	3	N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXA1.m

r628	r636
1		IBXA1 ; COMPILED XREF FOR FILE #350 ; ~~05/25~~/06
	1	IBXA1 ; COMPILED XREF FOR FILE #350 ; 10/08/06
2	2	;
3	3	S DIKZK=2

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXA2.m

r628	r636
1		IBXA2 ; COMPILED XREF FOR FILE #350 ; ~~05/25~~/06
	1	IBXA2 ; COMPILED XREF FOR FILE #350 ; 10/08/06
2	2	;
3	3	S DIKZK=1

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC1.m

r628	r636
1		IBXSC1 ; GENERATED FROM 'IB SCREEN1' INPUT TEMPLATE(#508), FILE 399;~~09/05~~/07
	1	IBXSC1 ; GENERATED FROM 'IB SCREEN1' INPUT TEMPLATE(#508), FILE 399;12/27/07
2	2	D DE G BEGIN
3	3	DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC11.m

r628	r636
1		IBXSC11 ; ;~~09/05~~/07
	1	IBXSC11 ; ;12/27/07
2	2	D DE G BEGIN
3	3	DE S DIE="^DPT(",DIC=DIE,DP=2,DL=2,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC110.m

r628	r636
1		IBXSC110 ; ;~~09/05~~/07
	1	IBXSC110 ; ;12/27/07
2	2	S X=DE(6),DIC=DIE
3	3	S A1B2TAG="PAT" D ^A1B2XFR

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC111.m

r628	r636
1		IBXSC111 ; ;~~09/05~~/07
	1	IBXSC111 ; ;12/27/07
2	2	S X=DG(DQ),DIC=DIE
3	3	S A1B2TAG="PAT" D ^A1B2XFR

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC112.m

r628	r636
1		IBXSC112 ; ;~~09/05~~/07
	1	IBXSC112 ; ;12/27/07
2	2	S X=DE(7),DIC=DIE
3	3	K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:""),Y=$P(Y(1),U,7) X:$D(^DD(2,.117,2)) ^(2) S X=Y S DIU=X K Y S X=DIV S X="" X ^DD(2,.115,1,1,2.4)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC113.m

r628	r636
1		IBXSC113 ; ;~~09/05~~/07
	1	IBXSC113 ; ;12/27/07
2	2	S X=DG(DQ),DIC=DIE
3	3	;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC114.m

-              r628
+              r636
 IBXSC114 ; ;09/05/07
+IBXSC114 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=2,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
 …
  S X=DE(3),DIC=DIE
  D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
+ S X=DE(3),DIC=DIE
+ X "K ^DPT(""AZVWVOE"",$E($TR(X,""ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!@#$%^&*()-_=+[]{}<>,./?:;'\|""),1,30),DA)"
  S X=DE(3),DIIX=2_U_DIFLD D AUDIT^DIET
 C3S S X="" G:DG(DQ)=X C3F1 K DB
 …
  S X=DG(DQ),DIC=DIE
  D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
+ S X=DG(DQ),DIC=DIE
+ X "S ^DPT(""AZVWVOE"",$E($TR(X,""ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!@#$%^&*()-_=+[]{}<>,./?:;'\|""),1,30),DA)="""""
  I $D(DE(3))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
 C3F1 Q
 …
+ ;
 C5F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
  F DIXR=603 S DIEZRXR(2,DIXR)=""
+ F DIXR=600 S DIEZRXR(2,DIXR)=""
+ Q
 X5 S DFN=DA I X="N" D TADD^DGLOCK
 …
  D ^IBXSC116
 C7F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
  F DIXR=603 S DIEZRXR(2,DIXR)=""
+ F DIXR=600 S DIEZRXR(2,DIXR)=""
+ Q
 X7 S %DT="E" D ^%DT S X=Y K:Y<1 X I $D(X) S DFN=DA D TAD^DGLOCK

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC115.m

r628	r636
1		IBXSC115 ; ;~~09/05~~/07
	1	IBXSC115 ; ;12/27/07
2	2	S X=DE(7),DIC=DIE
3	3	;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC116.m

r628	r636
1		IBXSC116 ; ;~~09/05~~/07
	1	IBXSC116 ; ;12/27/07
2	2	S X=DG(DQ),DIC=DIE
3	3	;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC117.m

-              r628
+              r636
 IBXSC117 ; ;09/05/07
+IBXSC117 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=2,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
 …
 C1S S X="" G:DG(DQ)=X C1F1 K DB
 C1F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
  F DIXR=603 S DIEZRXR(2,DIXR)=""
+ F DIXR=600 S DIEZRXR(2,DIXR)=""
+ Q
 X1 S %DT="E" D ^%DT S X=Y K:Y<1 X I $D(X) S DFN=DA D TAD^DGLOCK I $D(X),(X<$P(^DPT(DFN,.121),"^",7)) K X
 …
+ ;
 C2F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
  F DIXR=603 S DIEZRXR(2,DIXR)=""
+ F DIXR=600 S DIEZRXR(2,DIXR)=""
+ Q
 X2 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<2) X I $D(X) S DFN=DA D TAD^DGLOCK
 …
+ ;
 C4F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
  F DIXR=603 S DIEZRXR(2,DIXR)=""
+ F DIXR=600 S DIEZRXR(2,DIXR)=""
+ Q
 X4 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<2) X I $D(X) S DFN=DA D TAD^DGLOCK
 …
 C6S S X="" G:DG(DQ)=X C6F1 K DB
 C6F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
  F DIXR=603 S DIEZRXR(2,DIXR)=""
+ F DIXR=600 S DIEZRXR(2,DIXR)=""
+ Q
 X6 K:$L(X)>30!($L(X)<2) X I $D(X) S DFN=DA D TAD^DGLOCK
 …
 C7S S X="" G:DG(DQ)=X C7F1 K DB
 C7F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
  F DIXR=603 S DIEZRXR(2,DIXR)=""
+ F DIXR=600 S DIEZRXR(2,DIXR)=""
+ Q
 X7 K:$L(X)>30!($L(X)<2) X I $D(X) S DFN=DA D TAD^DGLOCK
 …
 C8S S X="" G:DG(DQ)=X C8F1 K DB
 C8F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
  F DIXR=603 S DIEZRXR(2,DIXR)=""
+ F DIXR=600 S DIEZRXR(2,DIXR)=""
+ Q
 X8 S DFN=DA D TAD^DGLOCK Q
 …
  D SET^DGREGDD1(DA,.1216,.121,6,$E(X,1,5))
 C9F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
  F DIXR=603 S DIEZRXR(2,DIXR)=""
+ F DIXR=600 S DIEZRXR(2,DIXR)=""
+ Q
 X9 K:X[""""!($A(X)=45) X I $D(X) S DFN=DA D TAD^DGLOCK I $D(X) K:$L(X)>20!($L(X)<5) X I $D(X) D ZIPIN^VAFADDR

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC118.m

-              r628
+              r636
 IBXSC118 ; ;09/05/07
+IBXSC118 ; ;12/27/07
  ;;
 N X,X1,X2 S DIXR=603 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
+N X,X1,X2 S DIXR=600 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
+ D
  . D TEMP^DGDDDTTM

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC12.m

r628	r636
1		IBXSC12 ; ;~~09/05~~/07
	1	IBXSC12 ; ;12/27/07
2	2	D DE G BEGIN
3	3	DE S DIE="^DPT(D0,.01,",DIC=DIE,DP=2.01,DL=3,DIEL=1,DU="" K DG,DE,DB Q:$O(^DPT(D0,.01,DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC13.m

r628	r636
1		IBXSC13 ; ;~~09/05~~/07
	1	IBXSC13 ; ;12/27/07
2	2	S X=DE(12),DIC=DIE
3	3	S DFN=DA D EN^DGMTCOR K DGMTCOR

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC14.m

r628	r636
1		IBXSC14 ; ;~~09/05~~/07
	1	IBXSC14 ; ;12/27/07
2	2	S X=DG(DQ),DIC=DIE
3	3	S DFN=DA D EN^DGMTCOR K DGMTCOR

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC15.m

r628	r636
1		IBXSC15 ; ;~~09/05~~/07
	1	IBXSC15 ; ;12/27/07
2	2	S X=DE(13),DIC=DIE
3	3	;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC16.m

r628	r636
1		IBXSC16 ; ;~~09/05~~/07
	1	IBXSC16 ; ;12/27/07
2	2	S X=DG(DQ),DIC=DIE
3	3	X "S DFN=DA D EN^DGMTR K DGREQF"

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC17.m

r628	r636
1		IBXSC17 ; ;~~09/05~~/07
	1	IBXSC17 ; ;12/27/07
2	2	D DE G BEGIN
3	3	DE S DIE="^DPT(",DIC=DIE,DP=2,DL=2,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC18.m

r628	r636
1		IBXSC18 ; ;~~09/05~~/07
	1	IBXSC18 ; ;12/27/07
2	2	S X=DE(5),DIC=DIE
3	3	S A1B2TAG="PAT" D ^A1B2XFR

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC19.m

r628	r636
1		IBXSC19 ; ;~~09/05~~/07
	1	IBXSC19 ; ;12/27/07
2	2	S X=DG(DQ),DIC=DIE
3	3	S A1B2TAG="PAT" D ^A1B2XFR

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC3.m

r628	r636
1		IBXSC3 ; GENERATED FROM 'IB SCREEN3' INPUT TEMPLATE(#574), FILE 399;~~02/03/08~~
	1	IBXSC3 ; GENERATED FROM 'IB SCREEN3' INPUT TEMPLATE(#574), FILE 399;12/27/07
2	2	D DE G BEGIN
3	3	DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC31.m

r628	r636
1		IBXSC31 ; ;~~02/03/08~~
	1	IBXSC31 ; ;12/27/07
2	2	S X=DE(22),DIC=DIE
3	3	K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(399,112,1,1,2.4)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC32.m

r628	r636
1		IBXSC32 ; ;~~02/03/08~~
	1	IBXSC32 ; ;12/27/07
2	2	S X=DG(DQ),DIC=DIE
3	3	K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y X ^DD(399,112,1,1,1.1) X ^DD(399,112,1,1,1.4)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC33.m

-              r628
+              r636
 IBXSC33 ; ;02/03/08
+IBXSC33 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
 …
 X14 I '$$SUPPPT^IBCEP7B(DA,1) S Y="@3212"
+ Q
 D:$D(DG)>9 F^DIE17,DE S DQ=15,DW="M1;2",DV="FX",DU="",DLB="PRIMARY PROVIDER #",DIFLD=122
+D:$D(DG)>9 F^DIE17,DE S DQ=15,DW="M1;2",DV="F",DU="",DLB="PRIMARY PROVIDER #",DIFLD=122
  S DE(DW)="C15^IBXSC33"
  S Y="@"
 …
+ ;
 C15F1 Q
 X15 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X
+X15 K:$L(X)>13!($L(X)<3) X
  I $D(X),X'?.ANP K X
+ Q

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC34.m

r628	r636
1		IBXSC34 ; ;~~02/03/08~~
	1	IBXSC34 ; ;12/27/07
2	2	S X=DG(DQ),DIC=DIE
3	3	K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$BPP^IBCNS2(DA) X ^DD(399,.21,1,1,1.4)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC35.m

r628	r636
1		IBXSC35 ; ;~~02/03/08~~
	1	IBXSC35 ; ;12/27/07
2	2	S X=DE(15),DIC=DIE
3	3	K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,2)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X="" X ^DD(399,122,1,1,2.4)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC36.m

-              r628
+              r636
 IBXSC36 ; ;02/03/08
+IBXSC36 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
 …
 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
 BEGIN S DNM="IBXSC36",DQ=1
 S DW="M1;2",DV="FX",DU="",DLB="PRIMARY PROVIDER #",DIFLD=122
+S DW="M1;2",DV="F",DU="",DLB="PRIMARY PROVIDER #",DIFLD=122
  S DE(DW)="C1^IBXSC36"
  S Y="@"
 …
+ ;
 C1F1 Q
 X1 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X
+X1 K:$L(X)>13!($L(X)<3) X
  I $D(X),X'?.ANP K X
+ Q
 …
+ Q
 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 G A
 S DW="M1;2",DV="FX",DU="",DLB="PRIMARY PROVIDER #",DIFLD=122
+S DW="M1;2",DV="F",DU="",DLB="PRIMARY PROVIDER #",DIFLD=122
  S DE(DW)="C7^IBXSC36"
  S X="IBPSID" Q:X  Q:$NA(@X)[U  S X=$G(@X)
 …
+ ;
 C7F1 Q
 X7 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X
+X7 K:$L(X)>13!($L(X)<3) X
  I $D(X),X'?.ANP K X
+ Q
 …
 X18 I '$$SUPPPT^IBCEP7B(DA,2) S Y="@3222"
+ Q
 S DW="M1;3",DV="FX",DU="",DLB="SECONDARY PROVIDER #",DIFLD=123
+S DW="M1;3",DV="F",DU="",DLB="SECONDARY PROVIDER #",DIFLD=123
  S DE(DW)="C19^IBXSC36"
  S Y="@"
 …
+ ;
 C19F1 Q
 X19 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X
+X19 K:$L(X)>13!($L(X)<3) X
  I $D(X),X'?.ANP K X
+ Q

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC37.m

-              r628
+              r636
 IBXSC37 ; ;02/03/08
+IBXSC37 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
 …
 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
 BEGIN S DNM="IBXSC37",DQ=1
 S DW="M1;3",DV="FX",DU="",DLB="SECONDARY PROVIDER #",DIFLD=123
+S DW="M1;3",DV="F",DU="",DLB="SECONDARY PROVIDER #",DIFLD=123
  S DE(DW)="C1^IBXSC37"
  S Y="@"
 …
+ ;
 C1F1 Q
 X1 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X
+X1 K:$L(X)>13!($L(X)<3) X
  I $D(X),X'?.ANP K X
+ Q
 …
+ Q
 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 G A
 S DW="M1;3",DV="FX",DU="",DLB="SECONDARY PROVIDER #",DIFLD=123
+S DW="M1;3",DV="F",DU="",DLB="SECONDARY PROVIDER #",DIFLD=123
  S DE(DW)="C7^IBXSC37"
  S X="IBPSID" Q:X  Q:$NA(@X)[U  S X=$G(@X)
 …
+ ;
 C7F1 Q
 X7 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X
+X7 K:$L(X)>13!($L(X)<3) X
  I $D(X),X'?.ANP K X
+ Q
 …
 X18 I '$$SUPPPT^IBCEP7B(DA,3) S Y="@3232"
+ Q
 S DW="M1;4",DV="FX",DU="",DLB="TERTIARY PROVIDER #",DIFLD=124
+S DW="M1;4",DV="F",DU="",DLB="TERTIARY PROVIDER #",DIFLD=124
  S DE(DW)="C19^IBXSC37"
  S Y="@"
 …
+ ;
 C19F1 Q
 X19 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X
+X19 K:$L(X)>13!($L(X)<3) X
  I $D(X),X'?.ANP K X
+ Q

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC38.m

-              r628
+              r636
 IBXSC38 ; ;02/03/08
+IBXSC38 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
 …
 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
 BEGIN S DNM="IBXSC38",DQ=1
 S DW="M1;4",DV="FX",DU="",DLB="TERTIARY PROVIDER #",DIFLD=124
+S DW="M1;4",DV="F",DU="",DLB="TERTIARY PROVIDER #",DIFLD=124
  S DE(DW)="C1^IBXSC38"
  S Y="@"
 …
+ ;
 C1F1 Q
 X1 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X
+X1 K:$L(X)>13!($L(X)<3) X
  I $D(X),X'?.ANP K X
+ Q
 …
+ Q
 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 G A
 S DW="M1;4",DV="FX",DU="",DLB="TERTIARY PROVIDER #",DIFLD=124
+S DW="M1;4",DV="F",DU="",DLB="TERTIARY PROVIDER #",DIFLD=124
  S DE(DW)="C7^IBXSC38"
  S X="IBPSID" Q:X  Q:$NA(@X)[U  S X=$G(@X)
 …
+ ;
 C7F1 Q
 X7 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X
+X7 K:$L(X)>13!($L(X)<3) X
  I $D(X),X'?.ANP K X
+ Q

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC39.m

r628	r636
1		IBXSC39 ; ;~~02/03/08~~
	1	IBXSC39 ; ;12/27/07
2	2	;;
3	3	1 N X,X1,X2 S DIXR=139 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC4.m

-              r628
+              r636
 IBXSC4 ; GENERATED FROM 'IB SCREEN4' INPUT TEMPLATE(#510), FILE 399;02/03/08
+IBXSC4 ; GENERATED FROM 'IB SCREEN4' INPUT TEMPLATE(#510), FILE 399;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
 …
+ Q
 S D=0 K DE(1) ;47
  S DIFLD=47,DGO="^IBXSC44",DC="2^399.047PA^CV^",DV="399.047M*P399.1'X",DW="0;1",DOW="VALUE CODE",DLB="Select "_DOW S:D DC=DC_D
+ S DIFLD=47,DGO="^IBXSC44",DC="2^399.047PA^CV^",DV="399.047M*P399.1'",DW="0;1",DOW="VALUE CODE",DLB="Select "_DOW S:D DC=DC_D
  S DU="DGCR(399.1,"
  G RE:D I $D(DSC(399.047))#2,$P(DSC(399.047),"I $D(^UTILITY(",1)="" X DSC(399.047) S D=$O(^(0)) S:D="" D=-1 G M30

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC41.m

r628	r636
1		IBXSC41 ; ;~~02/03/08~~
	1	IBXSC41 ; ;12/27/07
2	2	D DE G BEGIN
3	3	DE S DIE="^DGCR(399,D0,""OT"",",DIC=DIE,DP=399.048,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"OT",DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC42.m

-              r628
+              r636
 IBXSC42 ; ;02/03/08
+IBXSC42 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,D0,""OC"",",DIC=DIE,DP=399.041,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"OC",DA,""))=""
 …
 X7 I '$P(^DGCR(399.1,+^DGCR(399,DA(1),"OC",DA,0),0),U,10) S Y="@455"
+ Q
 S DW="0;4",DV="RDX",DU="",DLB="END DATE",DIFLD=.04
+S DW="0;4",DV="D",DU="",DLB="END DATE",DIFLD=.04
  G RE
 X8 S %DT="EX" D ^%DT S X=Y K:X<1 X I $D(X),X<$P($G(^DGCR(399,DA(1),"OC",DA,0)),U,2) K X
+X8 S %DT="EX" D ^%DT S X=Y K:Y<1 X
+ Q
+ ;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC43.m

r628	r636
1		IBXSC43 ; ;~~02/03/08~~
	1	IBXSC43 ; ;12/27/07
2	2	D DE G BEGIN
3	3	DE S DIE="^DGCR(399,D0,""CC"",",DIC=DIE,DP=399.04,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"CC",DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC44.m

-              r628
+              r636
 IBXSC44 ; ;02/03/08
+IBXSC44 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,D0,""CV"",",DIC=DIE,DP=399.047,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"CV",DA,""))=""
 …
 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
 BEGIN S DNM="IBXSC44",DQ=1+D G B
 S DW="0;1",DV="M*P399.1'X",DU="",DLB="VALUE CODE",DIFLD=.01
  S DE(DW)="C1^IBXSC44",DE(DW,"INDEX")=1
+S DW="0;1",DV="M*P399.1'",DU="",DLB="VALUE CODE",DIFLD=.01
+ S DE(DW)="C1^IBXSC44"
  S DU="DGCR(399.1,"
  G RE:'D S DQ=2 G 2
 …
  S X=DG(DQ),DIC=DIE
  S ^DGCR(399,DA(1),"CV","B",$E(X,1,30),DA)=""
+C1F1 N X,X1,X2 S DIXR=723 D C1X1(U) K X2 M X2=X D C1X1("O") K X1 M X1=X
+ K X M X=X2 D
+ . N DIEXARR M DIEXARR=X S DIEZCOND=1
+ . S X=$$COND^IBCVC(.DA,X1(1),X2(1))
+ . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND
+ . D REMOVE^IBCVC(.DA)
+ G C1F2
+C1X1(DION) K X
+ S X(1)=$G(@DIEZTMP@("V",399.047,DIIENS,.01,DION),$P($G(^DGCR(399,DA(1),"CV",DA,0)),U,1))
+ S X=$G(X(1))
+ Q
+C1F2 Q
+X1 S DIC("S")="I +$P($G(^DGCR(399.1,+Y,0)),U,11),$$ALLOWVC^IBCVC(DA(1),+Y)" D ^DIC K DIC S DIC=$G(DIE),X=+Y K:Y<0 X
+C1F1 Q
+X1 S DIC("S")="I +$P($G(^DGCR(399.1,+Y,0)),U,11)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
+ Q
+ ;
 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;2",DV="FX",DU="",DLB="VALUE",DIFLD=.02
+D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;2",DV="F",DU="",DLB="VALUE",DIFLD=.02
  G RE
 X2 K:$L(X)>10!($L(X)<1)!'$$FORMCHK^IBCVC(X,.DA) X
+X2 K:$L(X)>9!($L(X)<1) X
  I $D(X),X'?.ANP K X
+ Q

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC5.m

-              r628
+              r636
 IBXSC5 ; GENERATED FROM 'IB SCREEN5' INPUT TEMPLATE(#511), FILE 399;02/03/08
+IBXSC5 ; GENERATED FROM 'IB SCREEN5' INPUT TEMPLATE(#511), FILE 399;04/07/05
  D DE G BEGIN
 DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
 …
+ Q
 S D=0 K DE(1) ;47
  S DIFLD=47,DGO="^IBXSC54",DC="2^399.047PA^CV^",DV="399.047M*P399.1'X",DW="0;1",DOW="VALUE CODE",DLB="Select "_DOW S:D DC=DC_D
+ S DIFLD=47,DGO="^IBXSC54",DC="2^399.047PA^CV^",DV="399.047M*P399.1'",DW="0;1",DOW="VALUE CODE",DLB="Select "_DOW S:D DC=DC_D
  S DU="DGCR(399.1,"
  G RE:D I $D(DSC(399.047))#2,$P(DSC(399.047),"I $D(^UTILITY(",1)="" X DSC(399.047) S D=$O(^(0)) S:D="" D=-1 G M27

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC51.m

r628	r636
1		IBXSC51 ; ;0~~2/03/08~~
	1	IBXSC51 ; ;04/07/05
2	2	D DE G BEGIN
3	3	DE S DIE="^DGCR(399,D0,""OP"",",DIC=DIE,DP=399.043,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"OP",DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC52.m

-              r628
+              r636
 IBXSC52 ; ;02/03/08
+IBXSC52 ; ;04/07/05
  D DE G BEGIN
 DE S DIE="^DGCR(399,D0,""OC"",",DIC=DIE,DP=399.041,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"OC",DA,""))=""
 …
 X7 I '$P(^DGCR(399.1,+^DGCR(399,DA(1),"OC",DA,0),0),U,10) S Y="@555"
+ Q
 S DW="0;4",DV="RDX",DU="",DLB="END DATE",DIFLD=.04
+S DW="0;4",DV="D",DU="",DLB="END DATE",DIFLD=.04
  G RE
 X8 S %DT="EX" D ^%DT S X=Y K:X<1 X I $D(X),X<$P($G(^DGCR(399,DA(1),"OC",DA,0)),U,2) K X
+X8 S %DT="EX" D ^%DT S X=Y K:Y<1 X
+ Q
+ ;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC53.m

r628	r636
1		IBXSC53 ; ;0~~2/03/08~~
	1	IBXSC53 ; ;04/07/05
2	2	D DE G BEGIN
3	3	DE S DIE="^DGCR(399,D0,""CC"",",DIC=DIE,DP=399.04,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"CC",DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC54.m

-              r628
+              r636
 IBXSC54 ; ;02/03/08
+IBXSC54 ; ;04/07/05
  D DE G BEGIN
 DE S DIE="^DGCR(399,D0,""CV"",",DIC=DIE,DP=399.047,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"CV",DA,""))=""
 …
 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
 BEGIN S DNM="IBXSC54",DQ=1+D G B
 S DW="0;1",DV="M*P399.1'X",DU="",DLB="VALUE CODE",DIFLD=.01
  S DE(DW)="C1^IBXSC54",DE(DW,"INDEX")=1
+S DW="0;1",DV="M*P399.1'",DU="",DLB="VALUE CODE",DIFLD=.01
+ S DE(DW)="C1^IBXSC54"
  S DU="DGCR(399.1,"
  G RE:'D S DQ=2 G 2
 …
  S X=DG(DQ),DIC=DIE
  S ^DGCR(399,DA(1),"CV","B",$E(X,1,30),DA)=""
+C1F1 N X,X1,X2 S DIXR=723 D C1X1(U) K X2 M X2=X D C1X1("O") K X1 M X1=X
+ K X M X=X2 D
+ . N DIEXARR M DIEXARR=X S DIEZCOND=1
+ . S X=$$COND^IBCVC(.DA,X1(1),X2(1))
+ . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND
+ . D REMOVE^IBCVC(.DA)
+ G C1F2
+C1X1(DION) K X
+ S X(1)=$G(@DIEZTMP@("V",399.047,DIIENS,.01,DION),$P($G(^DGCR(399,DA(1),"CV",DA,0)),U,1))
+ S X=$G(X(1))
+ Q
+C1F2 Q
+X1 S DIC("S")="I +$P($G(^DGCR(399.1,+Y,0)),U,11),$$ALLOWVC^IBCVC(DA(1),+Y)" D ^DIC K DIC S DIC=$G(DIE),X=+Y K:Y<0 X
+C1F1 Q
+X1 S DIC("S")="I +$P($G(^DGCR(399.1,+Y,0)),U,11)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
+ Q
+ ;
 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;2",DV="FX",DU="",DLB="VALUE",DIFLD=.02
+D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;2",DV="F",DU="",DLB="VALUE",DIFLD=.02
  G RE
 X2 K:$L(X)>10!($L(X)<1)!'$$FORMCHK^IBCVC(X,.DA) X
+X2 K:$L(X)>9!($L(X)<1) X
  I $D(X),X'?.ANP K X
+ Q

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC6.m

r628	r636
1		IBXSC6 ; GENERATED FROM 'IB SCREEN6' INPUT TEMPLATE(#512), FILE 399;~~02/03/08~~
	1	IBXSC6 ; GENERATED FROM 'IB SCREEN6' INPUT TEMPLATE(#512), FILE 399;12/27/07
2	2	D DE G BEGIN
3	3	DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC61.m

r628	r636
1		IBXSC61 ; ;~~02/03/08~~
	1	IBXSC61 ; ;12/27/07
2	2	S X=DG(DQ),DIC=DIE
3	3	K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",1) X ^DD(399,.22,1,1,1.4)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC610.m

r628	r636
1		IBXSC610 ; ;~~02/03/08~~
	1	IBXSC610 ; ;12/27/07
2	2	S X=DE(22),DIC=DIE
3	3	K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU-X X ^DD(399,220,1,1,2.4)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC611.m

r628	r636
1		IBXSC611 ; ;~~02/03/08~~
	1	IBXSC611 ; ;12/27/07
2	2	S X=DG(DQ),DIC=DIE
3	3	K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,220,1,1,1.4)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC612.m

r628	r636
1		IBXSC612 ; ;~~02/03/08~~
	1	IBXSC612 ; ;12/27/07
2	2	S X=DE(12),DIC=DIE
3	3	K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(1)=$S($D(^DGCR(399,D0,"RC",D1,0)):^(0),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X="" X ^DD(399.042,.1,1,1,2.4)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC62.m

r628	r636
1		IBXSC62 ; ;~~02/03/08~~
	1	IBXSC62 ; ;12/27/07
2	2	D DE G BEGIN
3	3	DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC63.m

r628	r636
1		IBXSC63 ; ;~~02/03/08~~
	1	IBXSC63 ; ;12/27/07
2	2	S X=DG(DQ),DIC=DIE
3	3	K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,151,1,1,1.4)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC64.m

r628	r636
1		IBXSC64 ; ;~~02/03/08~~
	1	IBXSC64 ; ;12/27/07
2	2	S X=DG(DQ),DIC=DIE
3	3	K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,152,1,1,1.4)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC65.m

r628	r636
1		IBXSC65 ; ;~~02/03/08~~
	1	IBXSC65 ; ;12/27/07
2	2	S X=DE(23),DIC=DIE
3	3	;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC66.m

r628	r636
1		IBXSC66 ; ;~~02/03/08~~
	1	IBXSC66 ; ;12/27/07
2	2	S X=DG(DQ),DIC=DIE
3	3	X ^DD(399,161,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV D DIS^IBCU S X=X S DIH=$G(^DGCR(399,DIV(0),"U")),DIV=X S $P(^("U"),U,12)=DIV,DIH=399,DIG=162 D ^DICR

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC67.m

r628	r636
1		IBXSC67 ; ;~~02/03/08~~
	1	IBXSC67 ; ;12/27/07
2	2	D DE G BEGIN
3	3	DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC68.m

r628	r636
1		IBXSC68 ; ;~~02/03/08~~
	1	IBXSC68 ; ;12/27/07
2	2	D DE G BEGIN
3	3	DE S DIE="^DGCR(399,D0,""RC"",",DIC=DIE,DP=399.042,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"RC",DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC69.m

r628	r636
1		IBXSC69 ; ;~~02/03/08~~
	1	IBXSC69 ; ;12/27/07
2	2	S X=DG(DQ),DIC=DIE
3	3	K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,219,1,1,1.4)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC7.m

r628	r636
1		IBXSC7 ; GENERATED FROM 'IB SCREEN7' INPUT TEMPLATE(#513), FILE 399;~~07/22/08~~
	1	IBXSC7 ; GENERATED FROM 'IB SCREEN7' INPUT TEMPLATE(#513), FILE 399;12/27/07
2	2	D DE G BEGIN
3	3	DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC71.m

r628	r636
1		IBXSC71 ; ;~~07/22/08~~
	1	IBXSC71 ; ;12/27/07
2	2	D DE G BEGIN
3	3	DE S DIE="^DGCR(399,D0,""OP"",",DIC=DIE,DP=399.043,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"OP",DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC710.m

r628	r636
1		IBXSC710 ; ;~~07/22/08~~
	1	IBXSC710 ; ;12/27/07
2	2	S X=DG(DQ),DIC=DIE
3	3	K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,220,1,1,1.4)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC711.m

-              r628
+              r636
 IBXSC711 ; ;07/22/08
  S X=DE(12),DIC=DIE
+IBXSC711 ; ;12/27/07
+ S X=DE(11),DIC=DIE
  K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(1)=$S($D(^DGCR(399,D0,"RC",D1,0)):^(0),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X="" X ^DD(399.042,.1,1,1,2.4)
  S X=DE(12),DIC=DIE
+ S X=DE(11),DIC=DIE
  X ^DD(399.042,.1,1,2,2.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"RC",D1,0)):^(0),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"RC",DIV(1),0)),DIV=X S $P(^(0),U,15)=DIV,DIH=399.042,DIG=.15 D ^DICR

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC712.m

r628	r636
1		IBXSC712 ; ;~~07/22/08~~
	1	IBXSC712 ; ;12/27/07
2	2	D DE G BEGIN
3	3	DE S DIE="^DGCR(399,D0,""RC"",",DIC=DIE,DP=399.042,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"RC",DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC72.m

r628	r636
1		IBXSC72 ; ;~~07/22/08~~
	1	IBXSC72 ; ;12/27/07
2	2	S X=DG(DQ),DIC=DIE
3	3	K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",1) X ^DD(399,.22,1,1,1.4)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC73.m

r628	r636
1		IBXSC73 ; ;~~07/22/08~~
	1	IBXSC73 ; ;12/27/07
2	2	S X=DE(24),DIC=DIE
3	3	;

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC74.m

r628	r636
1		IBXSC74 ; ;~~07/22/08~~
	1	IBXSC74 ; ;12/27/07
2	2	S X=DG(DQ),DIC=DIE
3	3	K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,19),X=X S DIU=X K Y S X=DIV S X=$$FT^IBCU3(DA,1) X ^DD(399,.27,1,1,1.4)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC75.m

r628	r636
1		IBXSC75 ; ;~~07/22/08~~
	1	IBXSC75 ; ;12/27/07
2	2	D DE G BEGIN
3	3	DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC76.m

r628	r636
1		IBXSC76 ; ;~~07/22/08~~
	1	IBXSC76 ; ;12/27/07
2	2	S X=DG(DQ),DIC=DIE
3	3	K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,151,1,1,1.4)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC77.m

r628	r636
1		IBXSC77 ; ;~~07/22/08~~
	1	IBXSC77 ; ;12/27/07
2	2	S X=DG(DQ),DIC=DIE
3	3	K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,152,1,1,1.4)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC78.m

r628	r636
1		IBXSC78 ; ;~~07/22/08~~
	1	IBXSC78 ; ;12/27/07
2	2	D DE G BEGIN
3	3	DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC79.m

-              r628
+              r636
 IBXSC79 ; ;07/22/08
+IBXSC79 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,D0,""RC"",",DIC=DIE,DP=399.042,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"RC",DA,""))=""
  I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S %=$P(%Z,U,2) S:%]"" DE(2)=% S %=$P(%Z,U,3) S:%]"" DE(3)=% S %=$P(%Z,U,4) S:%]"" DE(4)=% S %=$P(%Z,U,5) S:%]"" DE(5)=% S %=$P(%Z,U,6) S:%]"" DE(7)=% S %=$P(%Z,U,7) S:%]"" DE(9)=%
  I  S %=$P(%Z,U,9) S:%]"" DE(6)=% S %=$P(%Z,U,10) S:%]"" DE(12)=% S %=$P(%Z,U,12) S:%]"" DE(13)=%
+ I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S %=$P(%Z,U,2) S:%]"" DE(2)=% S %=$P(%Z,U,3) S:%]"" DE(3)=% S %=$P(%Z,U,4) S:%]"" DE(4)=% S %=$P(%Z,U,5) S:%]"" DE(5)=% S %=$P(%Z,U,6) S:%]"" DE(6)=% S %=$P(%Z,U,7) S:%]"" DE(8)=%
+ I  S %=$P(%Z,U,10) S:%]"" DE(11)=% S %=$P(%Z,U,12) S:%]"" DE(12)=%
  K %Z Q
+ ;
 …
+ Q
+ ;
+D:$D(DG)>9 F^DIE17,DE S DQ=6,DW="0;9",DV="NJ8,2",DU="",DLB="NON-COVERED CHARGE",DIFLD=.09
+ G RE
+X6 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999)!(X<0)!(X?.E1"."3.N) X
+ Q
+ ;
+S DW="0;6",DV="*P81'",DU="",DLB="PROCEDURE",DIFLD=.06
+ S DE(DW)="C7^IBXSC79"
+D:$D(DG)>9 F^DIE17,DE S DQ=6,DW="0;6",DV="*P81'",DU="",DLB="PROCEDURE",DIFLD=.06
+ S DE(DW)="C6^IBXSC79"
  S DU="ICPT("
  G RE
 C7 G C7S:$D(DE(7))[0 K DB
  S X=DE(7),DIC=DIE
+C6 G C6S:$D(DE(6))[0 K DB
+ S X=DE(6),DIC=DIE
  K ^DGCR(399,"ASC1",$E(X,1,30),DA(1),DA)
  S X=DE(7),DIC=DIE
+ S X=DE(6),DIC=DIE
  K ^DGCR(399,"ASC2",DA(1),$E(X,1,30),DA)
 C7S S X="" G:DG(DQ)=X C7F1 K DB
+C6S S X="" G:DG(DQ)=X C6F1 K DB
  S X=DG(DQ),DIC=DIE
  I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC1",$E(X,1,30),DA(1),DA)=""
  S X=DG(DQ),DIC=DIE
  I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC2",DA(1),$E(X,1,30),DA)=""
 C7F1 Q
 X7 S ICPTVDT=$$BDATE^IBACSV($G(DA(1))),DIC("S")="I $$CPTACT^IBACSV(+Y,ICPTVDT)",DIC("W")="D EN^DDIOL(""   ""_$P($$CPT^IBACSV(+Y,ICPTVDT),U,2),,""?0"")" D ^DIC K DIC S DIC=$G(DIE),X=+Y K:Y<0 X
+ Q
+ ;
 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
 X8 I '$P(^DGCR(399,DA(1),"RC",DA,0),U,6) S Y="@758"
+ Q
 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW="0;7",DV="P40.8'X",DU="",DLB="DIVISION",DIFLD=.07
  S DE(DW)="C9^IBXSC79"
+C6F1 Q
+X6 S ICPTVDT=$$BDATE^IBACSV($G(DA(1))),DIC("S")="I $$CPTACT^IBACSV(+Y,ICPTVDT)",DIC("W")="D EN^DDIOL(""   ""_$P($$CPT^IBACSV(+Y,ICPTVDT),U,2),,""?0"")" D ^DIC K DIC S DIC=$G(DIE),X=+Y K:Y<0 X
+ Q
+ ;
+D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X7 I '$P(^DGCR(399,DA(1),"RC",DA,0),U,6) S Y="@758"
+ Q
+D:$D(DG)>9 F^DIE17,DE S DQ=8,DW="0;7",DV="P40.8'X",DU="",DLB="DIVISION",DIFLD=.07
+ S DE(DW)="C8^IBXSC79"
  S DU="DG(40.8,"
  S X=$$DEFDIV^IBCU7(DA(1))
  S Y=X
  G Y
 C9 G C9S:$D(DE(9))[0 K DB
  S X=DE(9),DIC=DIE
+C8 G C8S:$D(DE(8))[0 K DB
+ S X=DE(8),DIC=DIE
  K ^DGCR(399,"ASC1",+$P(^DGCR(399,DA(1),"RC",DA,0),U,6),DA(1),DA)
  S X=DE(9),DIC=DIE
+ S X=DE(8),DIC=DIE
  K ^DGCR(399,"ASC2",DA(1),+$P(^DGCR(399,DA(1),"RC",DA,0),U,6),DA)
 C9S S X="" G:DG(DQ)=X C9F1 K DB
+C8S S X="" G:DG(DQ)=X C8F1 K DB
  S X=DG(DQ),DIC=DIE
  I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC1",$P(^DGCR(399,DA(1),"RC",DA,0),U,6),DA(1),DA)=""
  S X=DG(DQ),DIC=DIE
  I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC2",DA(1),$P(^DGCR(399,DA(1),"RC",DA,0),U,6),DA)=""
 C9F1 Q
 X9 Q
 S DQ=11 ;@758
 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
 X11 I +$P(^DGCR(399,DA(1),"RC",DA,0),U,8) W !," AUTO ADDED CHARGE - NO CHANGE TO TYPE/COMPONENT" S Y="@759"
+ Q
 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW="0;10",DV="S",DU="",DLB="TYPE",DIFLD=.1
  S DE(DW)="C12^IBXSC79"
+C8F1 Q
+X8 Q
+S DQ=10 ;@758
+D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X10 I +$P(^DGCR(399,DA(1),"RC",DA,0),U,8) W !," AUTO ADDED CHARGE - NO CHANGE TO TYPE/COMPONENT" S Y="@759"
+ Q
+D:$D(DG)>9 F^DIE17,DE S DQ=11,DW="0;10",DV="S",DU="",DLB="TYPE",DIFLD=.1
+ S DE(DW)="C11^IBXSC79"
  S DU="1:INPT BS;2:OPT VST DT;3:RX;4:CPT;5:PROS;6:DRG;9:UNASSOCIATED;"
  G RE
 C12 G C12S:$D(DE(12))[0 K DB
+C11 G C11S:$D(DE(11))[0 K DB
  D ^IBXSC711
+C12S S X="" G:DG(DQ)=X C12F1 K DB
+ S X=DG(DQ),DIC=DIE
+ ;
+ S X=DG(DQ),DIC=DIE
+ ;
+C12F1 Q
+C11S S X="" G:DG(DQ)=X C11F1 K DB
+ S X=DG(DQ),DIC=DIE
+ ;
+ S X=DG(DQ),DIC=DIE
+ ;
+C11F1 Q
+X11 Q
+D:$D(DG)>9 F^DIE17,DE S DQ=12,DW="0;12",DV="S",DU="",DLB="COMPONENT",DIFLD=.12
+ S DU="1:INSTITUTIONAL;2:PROFESSIONAL;"
+ G RE
 X12 Q
+D:$D(DG)>9 F^DIE17,DE S DQ=13,DW="0;12",DV="S",DU="",DLB="COMPONENT",DIFLD=.12
+ S DU="1:INSTITUTIONAL;2:PROFESSIONAL;"
+ G RE
+X13 Q
+D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X13 I $S($P($G(^DGCR(399,DA(1),"RC",DA,0)),U,10)=3:0,1:$P($G(^(0)),U,10)'=4)!$P($G(^(0)),U,8) S Y="@759"
+ Q
 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
 X14 I $S($P($G(^DGCR(399,DA(1),"RC",DA,0)),U,10)=3:0,1:$P($G(^(0)),U,10)'=4)!$P($G(^(0)),U,8) S Y="@759"
+X14 I $P($G(^DGCR(399,DA(1),"RC",DA,0)),U,10)=4 S Y="@7581"
+ Q
 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
 X15 I $P($G(^DGCR(399,DA(1),"RC",DA,0)),U,10)=4 S Y="@7581"
+X15 S DGRVRCAL=1
+ Q
 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X16 S DGRVRCAL=1
+ Q
+D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X17 D LINKRX^IBCEU5(DA(1),DA)
+ Q
+D:$D(DG)>9 F^DIE17 G ^IBXSC712
+X16 D LINKRX^IBCEU5(DA(1),DA)
+ Q
+D:$D(DG)>9 F^DIE17 G ^IBXSC712

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC8.m

r628	r636
1		IBXSC8 ; GENERATED FROM 'IB SCREEN8' INPUT TEMPLATE(#514), FILE 399;~~09/05~~/07
	1	IBXSC8 ; GENERATED FROM 'IB SCREEN8' INPUT TEMPLATE(#514), FILE 399;12/27/07
2	2	D DE G BEGIN
3	3	DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC82.m

r628	r636
1		IBXSC82 ; GENERATED FROM 'IB SCREEN82' INPUT TEMPLATE(#577), FILE 399;~~09/05~~/07
	1	IBXSC82 ; GENERATED FROM 'IB SCREEN82' INPUT TEMPLATE(#577), FILE 399;12/27/07
2	2	D DE G BEGIN
3	3	DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC821.m

r628	r636
1		IBXSC821 ; ;~~09/05~~/07
	1	IBXSC821 ; ;12/27/07
2	2	D DE G BEGIN
3	3	DE S DIE="^DGCR(399,D0,""PRV"",",DIC=DIE,DP=399.0222,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"PRV",DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC822.m

r628	r636
1		IBXSC822 ; ;~~09/05~~/07
	1	IBXSC822 ; ;12/27/07
2	2	D DE G BEGIN
3	3	DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC823.m

r628	r636
1		IBXSC823 ; ;~~09/05~~/07
	1	IBXSC823 ; ;12/27/07
2	2	D DE G BEGIN
3	3	DE S DIE="^IBA(355.93,",DIC=DIE,DP=355.93,DL=2,DIEL=0,DU="" K DG,DE,DB Q:$O(^IBA(355.93,DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC824.m

r628	r636
1		IBXSC824 ; ;~~09/05~~/07
	1	IBXSC824 ; ;12/27/07
2	2	D DE G BEGIN
3	3	DE S DIE="^DGCR(399,D0,""PRV"",",DIC=DIE,DP=399.0222,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"PRV",DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC825.m

r628	r636
1		IBXSC825 ; ;~~09/05~~/07
	1	IBXSC825 ; ;12/27/07
2	2	S X=DG(DQ),DIC=DIE
3	3	K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(0)=X S X=Y(0)="SLF000" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"PRV",D1,0)):^(0),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(399.0222,.05,1,1,1.4)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC826.m

r628	r636
1		IBXSC826 ; ;~~09/05~~/07
	1	IBXSC826 ; ;12/27/07
2	2	S X=DG(DQ),DIC=DIE
3	3	D ATTREND^IBCU1(DA(1),DA,.13)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC827.m

r628	r636
1		IBXSC827 ; ;~~09/05~~/07
	1	IBXSC827 ; ;12/27/07
2	2	S X=DE(18),DIC=DIE
3	3	D ATTREND^IBCU1(DA(1),DA,.06)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC828.m

r628	r636
1		IBXSC828 ; ;~~09/05~~/07
	1	IBXSC828 ; ;12/27/07
2	2	S X=DG(DQ),DIC=DIE
3	3	D ATTREND^IBCU1(DA(1),DA,.06)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC829.m

r628	r636
1		IBXSC829 ; ;~~09/05~~/07
	1	IBXSC829 ; ;12/27/07
2	2	D DE G BEGIN
3	3	DE S DIE="^DGCR(399,D0,""PRV"",",DIC=DIE,DP=399.0222,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"PRV",DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC8H.m

r628	r636
1		IBXSC8H ; GENERATED FROM 'IB SCREEN8H' INPUT TEMPLATE(#515), FILE 399;~~10/29/04~~
	1	IBXSC8H ; GENERATED FROM 'IB SCREEN8H' INPUT TEMPLATE(#515), FILE 399;04/08/05
2	2	D DE G BEGIN
3	3	DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC8H1.m

r628	r636
1		IBXSC8H1 ; ;~~10/29/04~~
	1	IBXSC8H1 ; ;04/08/05
2	2	D DE G BEGIN
3	3	DE S DIE="^DGCR(399,D0,""PRV"",",DIC=DIE,DP=399.0222,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"PRV",DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC8H2.m

r628	r636
1		IBXSC8H2 ; ;~~10/29/04~~
	1	IBXSC8H2 ; ;04/08/05
2	2	D DE G BEGIN
3	3	DE S DIE="^IBA(355.93,",DIC=DIE,DP=355.93,DL=2,DIEL=0,DU="" K DG,DE,DB Q:$O(^IBA(355.93,DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC8H3.m

r628	r636
1		IBXSC8H3 ; ;~~10/29/04~~
	1	IBXSC8H3 ; ;04/08/05
2	2	D DE G BEGIN
3	3	DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC8H4.m

r628	r636
1		IBXSC8H4 ; ;~~10/29/04~~
	1	IBXSC8H4 ; ;04/08/05
2	2	D DE G BEGIN
3	3	DE S DIE="^DGCR(399,D0,""PRV"",",DIC=DIE,DP=399.0222,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"PRV",DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXST.m

r628	r636
1		IBXST ; GENERATED FROM 'IB STATUS' INPUT TEMPLATE(#506), FILE 399;~~10/29/04~~
	1	IBXST ; GENERATED FROM 'IB STATUS' INPUT TEMPLATE(#506), FILE 399;04/08/05
2	2	D DE G BEGIN
3	3	DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXST1.m

r628	r636
1		IBXST1 ; ;~~10/29/04~~
	1	IBXST1 ; ;04/08/05
2	2	D DE G BEGIN
3	3	DE S DIE="^DGCR(399,D0,""D1"",",DIC=DIE,DP=399.044,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"D1",DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXST2.m

r628	r636
1		IBXST2 ; ;~~10/29/04~~
	1	IBXST2 ; ;04/08/05
2	2	S X=DG(DQ),DIC=DIE
3	3	K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,14)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,12,1,1,1.4)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXST3.m

r628	r636
1		IBXST3 ; ;~~10/29/04~~
	1	IBXST3 ; ;04/08/05
2	2	S X=DE(19),DIC=DIE
3	3	K ^DGCR(399,"ALEX",$E(X,1,30),DA)

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXST4.m

r628	r636
1		IBXST4 ; ;~~10/29/04~~
	1	IBXST4 ; ;04/08/05
2	2	S X=DG(DQ),DIC=DIE
3	3	S ^DGCR(399,"ALEX",$E(X,1,30),DA)=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXST5.m

r628	r636
1		IBXST5 ; ;~~10/29/04~~
	1	IBXST5 ; ;04/08/05
2	2	D DE G BEGIN
3	3	DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX.m

-              r628
+              r636
 IBXX ; DRIVER FOR COMPILED XREFS FOR FILE #399 ; 07/22/08
+IBXX ; DRIVER FOR COMPILED XREFS FOR FILE #399 ; 12/27/07
+ ;
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
 …
 DI S DIKM1=0,DIKUM=0,DA(0)="",DV=0 F  S DV=$O(DA(DV)) Q:DV'>0  S DIKUM=DIKUM+1,DIKUP(DV)=DA(DV)
  S:DV="" DV=-1 S DH(1)=399,DIKUP=DA
  I $D(DIKKS) D:DIKZ1=DH(1) ^IBXX1 S DA=DIKUP D:DIKZ1=DH(1) ^IBXX15 D:DIKZ1'=DH(1) KILL D:DIKZ1'=DH(1) DA D:DIKZ1'=DH(1) SET D DA Q
+ I $D(DIKKS) D:DIKZ1=DH(1) ^IBXX1 S DA=DIKUP D:DIKZ1=DH(1) ^IBXX14 D:DIKZ1'=DH(1) KILL D:DIKZ1'=DH(1) DA D:DIKZ1'=DH(1) SET D DA Q
  I $D(DIKIL) D:DIKZ1=DH(1) ^IBXX1 S:DIKZ1=DH(1) DIKM1=1 D:DIKZ1'=DH(1) KILL S DA=DIKUP D:DIKM1>0 KIL1 D DA Q
  I $D(DIKST) D:DIKZ1=DH(1) ^IBXX15 D:DIKZ1'=DH(1) SET D DA Q
+ I $D(DIKST) D:DIKZ1=DH(1) ^IBXX14 D:DIKZ1'=DH(1) SET D DA Q
  I $D(DIKSAT) D SET1 D DA Q
+ Q
 …
  S DU=$E(DIK,1,$L(DIK)-1),DIKLK=$S(DIK[",":DU_")",1:DU) L +@DIKLK:10 K:'$T DIKLK
 C I @("$O("_DIK_"DA))'>0") S DA=$$C1(DA),^(0)=$P(@(DIK_"0)"),U,1,2)_U_DA_U_DCNT K DCNT L:$D(DIKLK) -@DIKLK Q
  S (DIKY,DA)=$O(^(DA)) G C:$P($G(^(DA,0)),U)']"" S DU=1,DCNT=DCNT+1 S:DA="" (DIKY,DA)=-1 D:DIKZ1=DH(1) ^IBXX15 D:DIKZ1'=DH(1) SET D:DIKZ1'=DH(1) DA K DB(0) S DA=DIKY G C
+ S (DIKY,DA)=$O(^(DA)) G C:$P($G(^(DA,0)),U)']"" S DU=1,DCNT=DCNT+1 S:DA="" (DIKY,DA)=-1 D:DIKZ1=DH(1) ^IBXX14 D:DIKZ1'=DH(1) SET D:DIKZ1'=DH(1) DA K DB(0) S DA=DIKY G C
+ Q
 C1(A) Q:$P($G(@(DIK_"A,0)")),U)]"" A
 …
 KILL S DIKILL=1,DIKZK=2
  I DIKZ1=399.0222,DIKUM'<1 S DIKM1=1 D A1^IBXX3 Q
  I DIKZ1=399.0304,DIKUM'<1 S DIKM1=1 D A1^IBXX4,A1^IBXX14 Q
+ I DIKZ1=399.0304,DIKUM'<1 S DIKM1=1 D A1^IBXX4,A1^IBXX13 Q
  I DIKZ1=399.041,DIKUM'<1 S DIKM1=1 D A1^IBXX5 Q
  I DIKZ1=399.042,DIKUM'<1 S DIKM1=1 D A1^IBXX6 Q
 …
  I DIKZ1=399.047,DIKUM'<1 S DIKM1=1 D A1^IBXX11 Q
  I DIKZ1=399.048,DIKUM'<1 S DIKM1=1 D A1^IBXX12 Q
+ I DIKZ1=399.077,DIKUM'<1 S DIKM1=1 D A1^IBXX13 Q
+ I DIKZ1=399.30416,DIKUM'<2 S DIKM1=2 D A1^IBXX14 Q
+ I DIKZ1=399.30416,DIKUM'<2 S DIKM1=2 D A1^IBXX13 Q
+ Q
 SET S DISET=1,DIKZK=1 K DIKPUSH
+ I DIKZ1=399.0222,DIKUM'<1 S DIKM1=1 D A1^IBXX19 Q
+ I DIKZ1=399.0304,DIKUM'<1 S DIKM1=1 D A1^IBXX20,A1^IBXX30 Q
+ I DIKZ1=399.041,DIKUM'<1 S DIKM1=1 D A1^IBXX21 Q
+ I DIKZ1=399.042,DIKUM'<1 S DIKM1=1 D A1^IBXX22 Q
+ I DIKZ1=399.043,DIKUM'<1 S DIKM1=1 D A1^IBXX23 Q
+ I DIKZ1=399.044,DIKUM'<1 S DIKM1=1 D A1^IBXX24 Q
+ I DIKZ1=399.045,DIKUM'<1 S DIKM1=1 D A1^IBXX25 Q
+ I DIKZ1=399.046,DIKUM'<1 S DIKM1=1 D A1^IBXX26 Q
+ I DIKZ1=399.047,DIKUM'<1 S DIKM1=1 D A1^IBXX27 Q
+ I DIKZ1=399.048,DIKUM'<1 S DIKM1=1 D A1^IBXX28 Q
+ I DIKZ1=399.077,DIKUM'<1 S DIKM1=1 D A1^IBXX29 Q
+ I DIKZ1=399.30416,DIKUM'<2 S DIKM1=2 D A1^IBXX30 Q
+ I DIKZ1=399.0222,DIKUM'<1 S DIKM1=1 D A1^IBXX18 Q
+ I DIKZ1=399.0304,DIKUM'<1 S DIKM1=1 D A1^IBXX19,A1^IBXX28 Q
+ I DIKZ1=399.041,DIKUM'<1 S DIKM1=1 D A1^IBXX20 Q
+ I DIKZ1=399.042,DIKUM'<1 S DIKM1=1 D A1^IBXX21 Q
+ I DIKZ1=399.043,DIKUM'<1 S DIKM1=1 D A1^IBXX22 Q
+ I DIKZ1=399.044,DIKUM'<1 S DIKM1=1 D A1^IBXX23 Q
+ I DIKZ1=399.045,DIKUM'<1 S DIKM1=1 D A1^IBXX24 Q
+ I DIKZ1=399.046,DIKUM'<1 S DIKM1=1 D A1^IBXX25 Q
+ I DIKZ1=399.047,DIKUM'<1 S DIKM1=1 D A1^IBXX26 Q
+ I DIKZ1=399.048,DIKUM'<1 S DIKM1=1 D A1^IBXX27 Q
+ I DIKZ1=399.30416,DIKUM'<2 S DIKM1=2 D A1^IBXX28 Q
+ Q
 KIL1 K @(DIK_"DA)") Q:'$D(^(0))

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX1.m

r628	r636
1		IBXX1 ; COMPILED XREF FOR FILE #399 ; ~~07/22/08~~
	1	IBXX1 ; COMPILED XREF FOR FILE #399 ; 12/27/07
2	2	;
3	3	S DIKZK=2

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX10.m

r628	r636
1		IBXX10 ; COMPILED XREF FOR FILE #399.046 ; ~~07/22/08~~
	1	IBXX10 ; COMPILED XREF FOR FILE #399.046 ; 12/27/07
2	2	;
3	3	S DA=0

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX11.m

r628	r636
1		IBXX11 ; COMPILED XREF FOR FILE #399.047 ; ~~07/22/08~~
	1	IBXX11 ; COMPILED XREF FOR FILE #399.047 ; 12/27/07
2	2	;
3	3	S DA=0

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX12.m

r628	r636
1		IBXX12 ; COMPILED XREF FOR FILE #399.048 ; ~~07/22/08~~
	1	IBXX12 ; COMPILED XREF FOR FILE #399.048 ; 12/27/07
2	2	;
3	3	S DA=0

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX13.m

-              r628
+              r636
 IBXX13 ; COMPILED XREF FOR FILE #399.077 ; 07/22/08
+IBXX13 ; COMPILED XREF FOR FILE #399.30416 ; 12/27/07
+ ;
  S DA=0
+ S DA(2)=DA(1) S DA(1)=0 S DA=0
 A1 ;
+ I $D(DIKILL) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1
+;
+A S DA=$O(^DGCR(399,DA(1),"TXC",DA)) I DA'>0 S DA=0 G END
+ I $D(DIKILL) K DIKLM S:DIKM1=2 DIKLM=1 S:DIKM1'=2&'$G(DIKPUSH(2)) DIKPUSH(2)=1,DA(2)=DA(1),DA(1)=DA,DA=0 G @DIKM1
+A S DA(1)=$O(^DGCR(399,DA(2),"CP",DA(1))) I DA(1)'>0 S DA(1)=0 G END
 ;
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"TXC",DA,0))
+B S DA=$O(^DGCR(399,DA(2),"CP",DA(1),"MOD",DA)) I DA'>0 S DA=0 Q:DIKM1=1  G A
+;
+ S DIKZ(0)=$G(^DGCR(399,DA(2),"CP",DA(1),"MOD",DA,0))
+ S X=$P(DIKZ(0),U,2)
+ I X'="" K ^DGCR(399,DA(2),"CP",DA(1),"MOD","C",$E(X,1,30),DA)
  S X=$P(DIKZ(0),U,1)
  I X'="" K ^DGCR(399,DA(1),"TXC","B",$E(X,1,30),DA)
  G:'$D(DIKLM) A Q:$D(DIKILL)
 END G ^IBXX14
+ I X'="" K ^DGCR(399,DA(2),"CP",DA(1),"MOD","B",$E(X,1,30),DA)
+ G:'$D(DIKLM) B Q:$D(DIKILL)
+END Q

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX14.m

-              r628
+              r636
 IBXX14 ; COMPILED XREF FOR FILE #399.30416 ; 07/22/08
+IBXX14 ; COMPILED XREF FOR FILE #399 ; 12/27/07
+ ;
+ S DA(2)=DA(1) S DA(1)=0 S DA=0
+A1 ;
+ I $D(DIKILL) K DIKLM S:DIKM1=2 DIKLM=1 S:DIKM1'=2&'$G(DIKPUSH(2)) DIKPUSH(2)=1,DA(2)=DA(1),DA(1)=DA,DA=0 G @DIKM1
+A S DA(1)=$O(^DGCR(399,DA(2),"CP",DA(1))) I DA(1)'>0 S DA(1)=0 G END
+;
+B S DA=$O(^DGCR(399,DA(2),"CP",DA(1),"MOD",DA)) I DA'>0 S DA=0 Q:DIKM1=1  G A
+;
+ S DIKZ(0)=$G(^DGCR(399,DA(2),"CP",DA(1),"MOD",DA,0))
+ S DIKZK=1
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,1)
+ I X'="" S ^DGCR(399,"B",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,1)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,1)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,.01,1,3,1.4)
+ S X=$P(DIKZ(0),U,1)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.01,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$S(($D(DUZ)#2):DUZ,1:"") X ^DD(399,.01,1,4,1.4)
+ S X=$P(DIKZ(0),U,1)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.01,1,5,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=$S($D(^IBE(350.9,1,1)):$P(^(1),U,6),1:"") X ^DD(399,.01,1,5,1.4)
+ S X=$P(DIKZ(0),U,1)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=1 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,13)=DIV,DIH=399,DIG=.13 D ^DICR
+ S X=$P(DIKZ(0),U,1)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.01,1,7,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,19),X=X S DIU=X K Y S X=DIV S X=3 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,19)=DIV,DIH=399,DIG=.19 D ^DICR
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
  S X=$P(DIKZ(0),U,2)
+ I X'="" K ^DGCR(399,DA(2),"CP",DA(1),"MOD","C",$E(X,1,30),DA)
+ S X=$P(DIKZ(0),U,1)
+ I X'="" K ^DGCR(399,DA(2),"CP",DA(1),"MOD","B",$E(X,1,30),DA)
+ G:'$D(DIKLM) B Q:$D(DIKILL)
+END Q
+ I X'="" S ^DGCR(399,"C",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,3)
+ I X'="" S ^DGCR(399,"D",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,3)
+ I X'="" S IBN=$P(^DGCR(399,DA,0),"^",2) S:$D(IBN) ^DGCR(399,"APDT",IBN,DA,9999999-X)="" K IBN
+ S X=$P(DIKZ(0),U,3)
+ I X'="" S ^DGCR(399,"ABNDT",DA,9999999-X)=""
+ S X=$P(DIKZ(0),U,4)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.04,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,24),X=X S DIU=X K Y S X=DIV S X=DIV,X=X S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,24)=DIV,DIH=399,DIG=.24 D ^DICR
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,5)
+ I X'="" S ^DGCR(399,"ABT",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,5)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.05,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,25),X=X S DIU=X K Y S X=DIV S X=$$TRIG05^IBCU4(X,D0) S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,25)=DIV,DIH=399,DIG=.25 D ^DICR
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,6)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.06,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,26),X=X S DIU=X K Y S X=DIV S X=DIV,X=X S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,26)=DIV,DIH=399,DIG=.26 D ^DICR
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,7)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.07,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X=DIV S X=1 X ^DD(399,.07,1,1,1.4)
+ S X=$P(DIKZ(0),U,7)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=$P(^DGCR(399.3,$P(^DGCR(399,DA,0),U,7),0),U,7) X ^DD(399,.07,1,2,1.4)
+ S X=$P(DIKZ(0),U,7)
+ I X'="" S ^DGCR(399,"AD",$E(X,1,30),DA)=""
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,8)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.08,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV S X=2 X ^DD(399,.08,1,1,1.4)
+ S X=$P(DIKZ(0),U,8)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.08,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=2 X ^DD(399,.08,1,2,1.4)
+ S X=$P(DIKZ(0),U,8)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.08,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV D DIS^IBCU S X=X X ^DD(399,.08,1,4,1.4)
+ S X=$P(DIKZ(0),U,8)
+ I X'="" S ^DGCR(399,"APTF",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,8)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=+$$LOS1^IBCU64(DA) X ^DD(399,.08,1,6,1.4)
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,11)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.11,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV D EN1^IBCU5 X ^DD(399,.11,1,1,1.4)
+ S X=$P(DIKZ(0),U,11)
+ I X'="" D EN^IBCU5
+ S X=$P(DIKZ(0),U,11)
+ I X'="" S DGRVRCAL=1
+ S X=$P(DIKZ(0),U,11)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.11,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,21),X=X S DIU=X K Y X ^DD(399,.11,1,4,1.1) X ^DD(399,.11,1,4,1.4)
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,13)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,.13,1,1,1.4)
+ S X=$P(DIKZ(0),U,13)
+ I X'="" I X>0,X<3,$P(^DGCR(399,DA,0),U,2) S ^DGCR(399,"AOP",$P(^(0),U,2),DA)=""
+ S X=$P(DIKZ(0),U,13)
+ I X'="" I +X=3 S ^DGCR(399,"AST",+X,DA)=""
+ S X=$P(DIKZ(0),U,13)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=Y(0),X=X S X=X=2 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X=DIV S X="1N" X ^DD(399,.13,1,4,1.4)
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,14)
+ I X'="" D BC^IBJVDEQ
+ S X=$P(DIKZ(0),U,17)
+ I X'="" S ^DGCR(399,"AC",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,19)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.19,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV S X=5 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,9)=DIV,DIH=399,DIG=.09 D ^DICR
+ S X=$P(DIKZ(0),U,19)
+ I X'="" S DGRVRCAL=1
+ S X=$P(DIKZ(0),U,19)
+ I X'="" D ALLID^IBCEP3(DA,.19,1)
+ S X=$P(DIKZ(0),U,19)
+ I X'="" D BILLPNS^IBCU(DA)
+ S X=$P(DIKZ(0),U,19)
+ I X'="" D ATTREND^IBCU1(DA,"","")
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,20)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.2,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=.5 X ^DD(399,.2,1,1,1.4)
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,21)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$BPP^IBCNS2(DA) X ^DD(399,.21,1,1,1.4)
+ S X=$P(DIKZ(0),U,21)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=('$$REQMRA^IBEFUNC(DA)&$$NEEDMRA^IBEFUNC(DA)) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X=DIV S X=0 X ^DD(399,.21,1,2,1.4)
+ S X=$P(DIKZ(0),U,21)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$S($$WNRBILL^IBEFUNC(DA,X):1,1:0) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X="" X ^DD(399,.21,1,3,1.4)
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,22)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",1) X ^DD(399,.22,1,1,1.4)
+ S X=$P(DIKZ(0),U,22)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",2) X ^DD(399,.22,1,2,1.4)
+ S X=$P(DIKZ(0),U,22)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",3) X ^DD(399,.22,1,3,1.4)
+ S X=$P(DIKZ(0),U,22)
+END G ^IBXX15

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX15.m

-              r628
+              r636
 IBXX15 ; COMPILED XREF FOR FILE #399 ; 07/22/08
+IBXX15 ; COMPILED XREF FOR FILE #399.0222 ; 12/27/07
+ ;
- S DIKZK=1
- S DIKZ(0)=$G(^DGCR(399,DA,0))
- S X=$P(DIKZ(0),U,1)
- I X'="" S ^DGCR(399,"B",$E(X,1,30),DA)=""
- S X=$P(DIKZ(0),U,1)
  I X'="" D
  .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,1)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,.01,1,3,1.4)
+ S X=$P(DIKZ(0),U,1)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.01,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$S(($D(DUZ)#2):DUZ,1:"") X ^DD(399,.01,1,4,1.4)
+ S X=$P(DIKZ(0),U,1)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.01,1,5,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=$S($D(^IBE(350.9,1,1)):$P(^(1),U,6),1:"") X ^DD(399,.01,1,5,1.4)
+ S X=$P(DIKZ(0),U,1)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=1 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,13)=DIV,DIH=399,DIG=.13 D ^DICR
+ S X=$P(DIKZ(0),U,1)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.01,1,7,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,19),X=X S DIU=X K Y S X=DIV S X=3 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,19)=DIV,DIH=399,DIG=.19 D ^DICR
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,2)
+ I X'="" S ^DGCR(399,"C",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,3)
+ I X'="" S ^DGCR(399,"D",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,3)
+ I X'="" S IBN=$P(^DGCR(399,DA,0),"^",2) S:$D(IBN) ^DGCR(399,"APDT",IBN,DA,9999999-X)="" K IBN
+ S X=$P(DIKZ(0),U,3)
+ I X'="" S ^DGCR(399,"ABNDT",DA,9999999-X)=""
+ S X=$P(DIKZ(0),U,4)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.04,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,24),X=X S DIU=X K Y S X=DIV S X=DIV,X=X S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,24)=DIV,DIH=399,DIG=.24 D ^DICR
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,5)
+ I X'="" S ^DGCR(399,"ABT",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,5)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.05,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,25),X=X S DIU=X K Y S X=DIV S X=$$TRIG05^IBCU4(X,D0) S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,25)=DIV,DIH=399,DIG=.25 D ^DICR
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,6)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.06,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,26),X=X S DIU=X K Y S X=DIV S X=DIV,X=X S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,26)=DIV,DIH=399,DIG=.26 D ^DICR
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,7)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.07,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X=DIV S X=1 X ^DD(399,.07,1,1,1.4)
+ S X=$P(DIKZ(0),U,7)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=$P(^DGCR(399.3,$P(^DGCR(399,DA,0),U,7),0),U,7) X ^DD(399,.07,1,2,1.4)
+ S X=$P(DIKZ(0),U,7)
+ I X'="" S ^DGCR(399,"AD",$E(X,1,30),DA)=""
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,8)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.08,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV S X=2 X ^DD(399,.08,1,1,1.4)
+ S X=$P(DIKZ(0),U,8)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.08,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=2 X ^DD(399,.08,1,2,1.4)
+ S X=$P(DIKZ(0),U,8)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.08,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV D DIS^IBCU S X=X X ^DD(399,.08,1,4,1.4)
+ S X=$P(DIKZ(0),U,8)
+ I X'="" S ^DGCR(399,"APTF",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,8)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=+$$LOS1^IBCU64(DA) X ^DD(399,.08,1,6,1.4)
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,11)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.11,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV D EN1^IBCU5 X ^DD(399,.11,1,1,1.4)
+ S X=$P(DIKZ(0),U,11)
+ I X'="" D EN^IBCU5
+ S X=$P(DIKZ(0),U,11)
+ I X'="" S DGRVRCAL=1
+ S X=$P(DIKZ(0),U,11)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.11,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,21),X=X S DIU=X K Y X ^DD(399,.11,1,4,1.1) X ^DD(399,.11,1,4,1.4)
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,13)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,.13,1,1,1.4)
+ S X=$P(DIKZ(0),U,13)
+ I X'="" I X>0,X<3,$P(^DGCR(399,DA,0),U,2) S ^DGCR(399,"AOP",$P(^(0),U,2),DA)=""
+ S X=$P(DIKZ(0),U,13)
+ I X'="" I +X=3 S ^DGCR(399,"AST",+X,DA)=""
+ S X=$P(DIKZ(0),U,13)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=Y(0),X=X S X=X=2 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X=DIV S X="1N" X ^DD(399,.13,1,4,1.4)
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,14)
+ I X'="" D BC^IBJVDEQ
+ S X=$P(DIKZ(0),U,17)
+ I X'="" S ^DGCR(399,"AC",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,19)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.19,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV S X=5 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,9)=DIV,DIH=399,DIG=.09 D ^DICR
+ S X=$P(DIKZ(0),U,19)
+ I X'="" S DGRVRCAL=1
+ S X=$P(DIKZ(0),U,19)
+ I X'="" D ALLID^IBCEP3(DA,.19,1)
+ S X=$P(DIKZ(0),U,19)
+ I X'="" D BILLPNS^IBCU(DA)
+ S X=$P(DIKZ(0),U,19)
+ I X'="" D ATTREND^IBCU1(DA,"","")
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,20)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.2,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=.5 X ^DD(399,.2,1,1,1.4)
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,21)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$BPP^IBCNS2(DA) X ^DD(399,.21,1,1,1.4)
+ S X=$P(DIKZ(0),U,21)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=('$$REQMRA^IBEFUNC(DA)&$$NEEDMRA^IBEFUNC(DA)) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X=DIV S X=0 X ^DD(399,.21,1,2,1.4)
+ S X=$P(DIKZ(0),U,21)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$S($$WNRBILL^IBEFUNC(DA,X):1,1:0) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X="" X ^DD(399,.21,1,3,1.4)
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X=DIV S X=$$PRVQUAL^IBCU(DA,"",1) X ^DD(399,.22,1,4,1.4)
  S X=$P(DIKZ(0),U,22)
  I X'="" D
  .N DIK,DIV,DIU,DIN
  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",1) X ^DD(399,.22,1,1,1.4)
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=$$PRVQUAL^IBCU(DA,"",2) X ^DD(399,.22,1,5,1.4)
  S X=$P(DIKZ(0),U,22)
  I X'="" D
  .N DIK,DIV,DIU,DIN
  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",2) X ^DD(399,.22,1,2,1.4)
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV S X=$$PRVQUAL^IBCU(DA,"",3) X ^DD(399,.22,1,6,1.4)
  S X=$P(DIKZ(0),U,22)
  I X'="" D
  .N DIK,DIV,DIU,DIN
  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",3) X ^DD(399,.22,1,3,1.4)
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$CLIAREQ^IBCEP8A(DA) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$CLIA^IBCEP8A(DA) X ^DD(399,.22,1,7,1.4)
  S X=$P(DIKZ(0),U,22)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U3")):^("U3"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$P($$TAXDEF^IBCEP81(DIV(0)),U,2) X ^DD(399,.22,1,8,1.4)
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,25)
+ I X'="" D ALLID^IBCEP3(DA,.25,1)
+ S X=$P(DIKZ(0),U,26)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X=DIV S X=DIV,X=X S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,6)=DIV,DIH=399,DIG=.06 D ^DICR
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,27)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,19),X=X S DIU=X K Y S X=DIV S X=$$FT^IBCU3(DA,1) X ^DD(399,.27,1,1,1.4)
+ S DIKZ("S")=$G(^DGCR(399,DA,"S"))
+ S X=$P(DIKZ("S"),U,1)
+ I X'="" S ^DGCR(399,"APD",$E(X,1,30),DA)=""
+ S X=$P(DIKZ("S"),U,3)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,4)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,3,1,1,1.4)
+ S X=$P(DIKZ("S"),U,3)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,3,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,3,1,2,1.4)
+ S DIKZ("S")=$G(^DGCR(399,DA,"S"))
+ S X=$P(DIKZ("S"),U,7)
+ I X'="" S ^DGCR(399,"APM",$E(X,1,30),DA)=""
+ S X=$P(DIKZ("S"),U,9)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,9,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,9,1,1,1.4)
+ S X=$P(DIKZ("S"),U,9)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,9,1,2,69.2) S X=X="YES",Y=X,X=Y(2),X=X&Y I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,9,1,2,1.4)
+ S X=$P(DIKZ("S"),U,9)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y=Y(0) X:$D(^DD(399,9,2)) ^(2) S X=Y="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=3 X ^DD(399,9,1,3,1.4)
+ S X=$P(DIKZ("S"),U,9)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$EXTERNAL^DIDU(399,9,"",Y(0))="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X="" X ^DD(399,9,1,4,1.4)
+ S DIKZ("S")=$G(^DGCR(399,DA,"S"))
+ S X=$P(DIKZ("S"),U,10)
+ I X'="" S ^DGCR(399,"APD3",$E(X,1,30),DA)=""
+ S X=$P(DIKZ("S"),U,12)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,14)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,12,1,1,1.4)
+ S X=$P(DIKZ("S"),U,12)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,12,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=DUZ S DIH=$G(^DGCR(399,DIV(0),"S")),DIV=X S $P(^("S"),U,15)=DIV,DIH=399,DIG=15 D ^DICR
+ S X=$P(DIKZ("S"),U,12)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,12,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=DUZ S DIH=$G(^DGCR(399,DIV(0),"S")),DIV=X S $P(^("S"),U,13)=DIV,DIH=399,DIG=13 D ^DICR
+ S X=$P(DIKZ("S"),U,12)
+ I X'="" S ^DGCR(399,"AP",$E(X,1,30),DA)=""
+ S DIKZ("S")=$G(^DGCR(399,DA,"S"))
+ S X=$P(DIKZ("S"),U,14)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=4 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,13)=DIV,DIH=399,DIG=.13 D ^DICR
+ S X=$P(DIKZ("S"),U,14)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=DUZ S DIH=$G(^DGCR(399,DIV(0),"S")),DIV=X S $P(^("S"),U,15)=DIV,DIH=399,DIG=15 D ^DICR
+ S DIKZ("S")=$G(^DGCR(399,DA,"S"))
+ S X=$P(DIKZ("S"),U,16)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$EXTERNAL^DIDU(399,16,"",Y(0))="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,17),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,16,1,1,1.4)
+ S X=$P(DIKZ("S"),U,16)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$EXTERNAL^DIDU(399,16,"",Y(0))="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,18),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,16,1,2,1.4)
+ S DIKZ("S")=$G(^DGCR(399,DA,"S"))
+ S X=$P(DIKZ("S"),U,17)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,16),X=X S X=X=1 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=7 X ^DD(399,17,1,1,1.4)
+ S DIKZ("TX")=$G(^DGCR(399,DA,"TX"))
+ S X=$P(DIKZ("TX"),U,2)
+ I X'="" S ^DGCR(399,"ALEX",$E(X,1,30),DA)=""
+ S X=$P(DIKZ("TX"),U,5)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,24,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,24,1,1,1.4)
+ S DIKZ("TX")=$G(^DGCR(399,DA,"TX"))
+ S X=$P(DIKZ("TX"),U,6)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=Y(0),X=X S X=X=1 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=2 X ^DD(399,25,1,1,1.4)
+ S X=$P(DIKZ("TX"),U,6)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,25,1,2,69.2) S X=X S X=X="",Y=X,X=Y(2),X=X&Y I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,25,1,2,1.4)
+ S X=$P(DIKZ("TX"),U,6)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,25,1,3,69.2) S X=X S X=X="",Y=X,X=Y(2),X=X&Y I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,7),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,25,1,3,1.4)
+ S DIKZ("C")=$G(^DGCR(399,DA,"C"))
+ S X=$P(DIKZ("C"),U,14)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,64,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"C")):^("C"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X=DIV S X=$P(^ICD9(+X,0),"^",3) X ^DD(399,64,1,1,1.4)
+ S DIKZ("M")=$G(^DGCR(399,DA,"M"))
+ S X=$P(DIKZ("M"),U,1)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,X,1) X ^DD(399,101,1,1,1.4)
+ S X=$P(DIKZ("M"),U,1)
 END G ^IBXX16

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX16.m

-              r628
+              r636
 IBXX16 ; COMPILED XREF FOR FILE #399.0222 ; 07/22/08
+IBXX16 ; COMPILED XREF FOR FILE #399.0222 ; 12/27/07
+ ;
  I X'="" D
  .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X=DIV S X=$$PRVQUAL^IBCU(DA,"",1) X ^DD(399,.22,1,4,1.4)
+ S X=$P(DIKZ(0),U,22)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=$$PRVQUAL^IBCU(DA,"",2) X ^DD(399,.22,1,5,1.4)
+ S X=$P(DIKZ(0),U,22)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV S X=$$PRVQUAL^IBCU(DA,"",3) X ^DD(399,.22,1,6,1.4)
+ S X=$P(DIKZ(0),U,22)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$CLIAREQ^IBCEP8A(DA) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$CLIA^IBCEP8A(DA) X ^DD(399,.22,1,7,1.4)
+ S X=$P(DIKZ(0),U,22)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U3")):^("U3"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$P($$TAXDEF^IBCEP81(DIV(0)),U,2) X ^DD(399,.22,1,8,1.4)
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,25)
+ I X'="" D ALLID^IBCEP3(DA,.25,1)
+ S X=$P(DIKZ(0),U,26)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X=DIV S X=DIV,X=X S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,6)=DIV,DIH=399,DIG=.06 D ^DICR
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,27)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,19),X=X S DIU=X K Y S X=DIV S X=$$FT^IBCU3(DA,1) X ^DD(399,.27,1,1,1.4)
+ S DIKZ("S")=$G(^DGCR(399,DA,"S"))
+ S X=$P(DIKZ("S"),U,1)
+ I X'="" S ^DGCR(399,"APD",$E(X,1,30),DA)=""
+ S X=$P(DIKZ("S"),U,3)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,4)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,3,1,1,1.4)
+ S X=$P(DIKZ("S"),U,3)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,3,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,3,1,2,1.4)
+ S DIKZ("S")=$G(^DGCR(399,DA,"S"))
+ S X=$P(DIKZ("S"),U,7)
+ I X'="" S ^DGCR(399,"APM",$E(X,1,30),DA)=""
+ S X=$P(DIKZ("S"),U,9)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,9,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,9,1,1,1.4)
+ S X=$P(DIKZ("S"),U,9)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,9,1,2,69.2) S X=X="YES",Y=X,X=Y(2),X=X&Y I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,9,1,2,1.4)
+ S X=$P(DIKZ("S"),U,9)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y=Y(0) X:$D(^DD(399,9,2)) ^(2) S X=Y="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=3 X ^DD(399,9,1,3,1.4)
+ S X=$P(DIKZ("S"),U,9)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$EXTERNAL^DIDU(399,9,"",Y(0))="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X="" X ^DD(399,9,1,4,1.4)
+ S DIKZ("S")=$G(^DGCR(399,DA,"S"))
+ S X=$P(DIKZ("S"),U,10)
+ I X'="" S ^DGCR(399,"APD3",$E(X,1,30),DA)=""
+ S X=$P(DIKZ("S"),U,12)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,14)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,12,1,1,1.4)
+ S X=$P(DIKZ("S"),U,12)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,12,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=DUZ S DIH=$G(^DGCR(399,DIV(0),"S")),DIV=X S $P(^("S"),U,15)=DIV,DIH=399,DIG=15 D ^DICR
+ S X=$P(DIKZ("S"),U,12)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,12,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=DUZ S DIH=$G(^DGCR(399,DIV(0),"S")),DIV=X S $P(^("S"),U,13)=DIV,DIH=399,DIG=13 D ^DICR
+ S X=$P(DIKZ("S"),U,12)
+ I X'="" S ^DGCR(399,"AP",$E(X,1,30),DA)=""
+ S DIKZ("S")=$G(^DGCR(399,DA,"S"))
+ S X=$P(DIKZ("S"),U,14)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=4 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,13)=DIV,DIH=399,DIG=.13 D ^DICR
+ S X=$P(DIKZ("S"),U,14)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=DUZ S DIH=$G(^DGCR(399,DIV(0),"S")),DIV=X S $P(^("S"),U,15)=DIV,DIH=399,DIG=15 D ^DICR
+ S DIKZ("S")=$G(^DGCR(399,DA,"S"))
+ S X=$P(DIKZ("S"),U,16)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$EXTERNAL^DIDU(399,16,"",Y(0))="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,17),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,16,1,1,1.4)
+ S X=$P(DIKZ("S"),U,16)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$EXTERNAL^DIDU(399,16,"",Y(0))="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,18),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,16,1,2,1.4)
+ S DIKZ("S")=$G(^DGCR(399,DA,"S"))
+ S X=$P(DIKZ("S"),U,17)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,16),X=X S X=X=1 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=7 X ^DD(399,17,1,1,1.4)
+ S DIKZ("TX")=$G(^DGCR(399,DA,"TX"))
+ S X=$P(DIKZ("TX"),U,2)
+ I X'="" S ^DGCR(399,"ALEX",$E(X,1,30),DA)=""
+ S X=$P(DIKZ("TX"),U,5)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,24,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,24,1,1,1.4)
+ S DIKZ("TX")=$G(^DGCR(399,DA,"TX"))
+ S X=$P(DIKZ("TX"),U,6)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=Y(0),X=X S X=X=1 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=2 X ^DD(399,25,1,1,1.4)
+ S X=$P(DIKZ("TX"),U,6)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,25,1,2,69.2) S X=X S X=X="",Y=X,X=Y(2),X=X&Y I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,25,1,2,1.4)
+ S X=$P(DIKZ("TX"),U,6)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,25,1,3,69.2) S X=X S X=X="",Y=X,X=Y(2),X=X&Y I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,7),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,25,1,3,1.4)
+ S DIKZ("C")=$G(^DGCR(399,DA,"C"))
+ S X=$P(DIKZ("C"),U,14)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,64,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"C")):^("C"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X=DIV S X=$P(^ICD9(+X,0),"^",3) X ^DD(399,64,1,1,1.4)
+ S DIKZ("M")=$G(^DGCR(399,DA,"M"))
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $$COBN^IBCEF(DA)=1 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y X ^DD(399,101,1,2,1.1) X ^DD(399,101,1,2,1.4)
  S X=$P(DIKZ("M"),U,1)
  I X'="" D
  .N DIK,DIV,DIU,DIN
  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,X,1) X ^DD(399,101,1,1,1.4)
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$S($$MCRWNR^IBEFUNC(X):$$COBN^IBCEF(DA)=1,1:0) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X="" X ^DD(399,101,1,3,1.4)
  S X=$P(DIKZ("M"),U,1)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X=DIV S X=$$PRVQUAL^IBCU(DA,X,1) X ^DD(399,101,1,4,1.4)
+ S DIKZ("M")=$G(^DGCR(399,DA,"M"))
+ S X=$P(DIKZ("M"),U,2)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,X,2) X ^DD(399,102,1,2,1.4)
+ S X=$P(DIKZ("M"),U,2)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $$COBN^IBCEF(DA)=2 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y X ^DD(399,102,1,3,1.1) X ^DD(399,102,1,3,1.4)
+ S X=$P(DIKZ("M"),U,2)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$S($$MCRWNR^IBEFUNC(X):$$COBN^IBCEF(DA)=2,1:0) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X="" X ^DD(399,102,1,4,1.4)
+ S X=$P(DIKZ("M"),U,2)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=$$PRVQUAL^IBCU(DA,X,2) X ^DD(399,102,1,5,1.4)
+ S DIKZ("M")=$G(^DGCR(399,DA,"M"))
+ S X=$P(DIKZ("M"),U,3)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,X,3) X ^DD(399,103,1,2,1.4)
+ S X=$P(DIKZ("M"),U,3)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV S X=$$PRVQUAL^IBCU(DA,X,3) X ^DD(399,103,1,3,1.4)
+ S DIKZ("M")=$G(^DGCR(399,DA,"M"))
+ S X=$P(DIKZ("M"),U,11)
+ I X'="" D MAILIN^IBCU5
+ S X=$P(DIKZ("M"),U,11)
+ I X'="" S DGRVRCAL=1
+ S X=$P(DIKZ("M"),U,12)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y X ^DD(399,112,1,1,1.1) X ^DD(399,112,1,1,1.4)
+ S X=$P(DIKZ("M"),U,12)
+ I X'="" D IX^IBCNS2(DA,"I1")
+ S X=$P(DIKZ("M"),U,12)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,112,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$BPP^IBCNS2(DA,1) X ^DD(399,112,1,3,1.4)
+ S DIKZ("M")=$G(^DGCR(399,DA,"M"))
+ S X=$P(DIKZ("M"),U,13)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y X ^DD(399,113,1,1,1.1) X ^DD(399,113,1,1,1.4)
+ S X=$P(DIKZ("M"),U,13)
+ I X'="" D IX^IBCNS2(DA,"I2")
+ S X=$P(DIKZ("M"),U,13)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,113,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$BPP^IBCNS2(DA,1) X ^DD(399,113,1,3,1.4)
+ S DIKZ("M")=$G(^DGCR(399,DA,"M"))
+ S X=$P(DIKZ("M"),U,14)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y X ^DD(399,114,1,1,1.1) X ^DD(399,114,1,1,1.4)
+ S X=$P(DIKZ("M"),U,14)
+ I X'="" D IX^IBCNS2(DA,"I3")
+ S X=$P(DIKZ("M"),U,14)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,114,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$BPP^IBCNS2(DA) X ^DD(399,114,1,3,1.4)
+ S DIKZ("MP")=$G(^DGCR(399,DA,"MP"))
+ S X=$P(DIKZ("MP"),U,1)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,19),X=X S DIU=X K Y S X=DIV S X=$$FT^IBCU3(DA,1) X ^DD(399,135,1,2,1.4)
+ S X=$P(DIKZ("MP"),U,1)
+ I X'="" D MAILA^IBCU5
+ S X=$P(DIKZ("MP"),U,1)
+ I X'="" S DGRVRCAL=1
+ S DIKZ("MP")=$G(^DGCR(399,DA,"MP"))
+ S X=$P(DIKZ("MP"),U,2)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$WNRBILL^IBEFUNC(DA) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y X ^DD(399,136,1,1,1.1) X ^DD(399,136,1,1,1.4)
+ S DIKZ("U")=$G(^DGCR(399,DA,"U"))
+ S X=$P(DIKZ("U"),U,1)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,151,1,1,1.4)
+ S X=$P(DIKZ("U"),U,1)
+ I X'="" S DGRVRCAL=1
+ S X=$P(DIKZ("U"),U,1)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I +$G(^DGCR(399,DA,"U1"))=0 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X=0 X ^DD(399,151,1,3,1.4)
+ S X=$P(DIKZ("U"),U,1)
+ I X'="" S:$P(^DGCR(399,DA,0),"^",2) ^DGCR(399,"APDS",$P(^(0),U,2),-X,DA)=""
+ S DIKZ("U")=$G(^DGCR(399,DA,"U"))
+ S X=$P(DIKZ("U"),U,2)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,152,1,1,1.4)
+ S X=$P(DIKZ("U"),U,2)
+ I X'="" S DGRVRCAL=1
+ S DIKZ("U")=$G(^DGCR(399,DA,"U"))
+ S X=$P(DIKZ("U"),U,11)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,161,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV D DIS^IBCU S X=X S DIH=$G(^DGCR(399,DIV(0),"U")),DIV=X S $P(^("U"),U,12)=DIV,DIH=399,DIG=162 D ^DICR
+ S DIKZ("U")=$G(^DGCR(399,DA,"U"))
+ S X=$P(DIKZ("U"),U,15)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=($P($G(^DGCR(399,DA,"U2")),U,2)=""&$$INPAT^IBCEF(DA,1)) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIV X ^DD(399,165,1,1,1.4)
+ S X=$P(DIKZ("U"),U,15)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,165,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV N Z S X=$$LOS1^IBCU64(DA,.Z),X=+$G(Z) X ^DD(399,165,1,2,1.4)
+ S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
+ S X=$P(DIKZ("U2"),U,4)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,218,1,1,1.4)
+ S X=$P(DIKZ("U2"),U,4)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="PRIOR PAYMENT(S)" X ^DD(399,218,1,2,1.4)
+ S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
+ S X=$P(DIKZ("U2"),U,5)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,219,1,1,1.4)
+ S X=$P(DIKZ("U2"),U,5)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="PRIOR PAYMENT(S)" X ^DD(399,219,1,2,1.4)
+ S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
+ S X=$P(DIKZ("U2"),U,6)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,220,1,1,1.4)
+ S X=$P(DIKZ("U2"),U,6)
 END G ^IBXX17

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX17.m

-              r628
+              r636
 IBXX17 ; COMPILED XREF FOR FILE #399.0222 ; 07/22/08
+IBXX17 ; COMPILED XREF FOR FILE #399.0222 ; 12/27/07
+ ;
  I X'="" D
  .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $$COBN^IBCEF(DA)=1 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y X ^DD(399,101,1,2,1.1) X ^DD(399,101,1,2,1.4)
+ S X=$P(DIKZ("M"),U,1)
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="PRIOR PAYMENT(S)" X ^DD(399,220,1,2,1.4)
+ S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
+ S X=$P(DIKZ("U2"),U,10)
  I X'="" D
  .N DIK,DIV,DIU,DIN
  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$S($$MCRWNR^IBEFUNC(X):$$COBN^IBCEF(DA)=1,1:0) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X="" X ^DD(399,101,1,3,1.4)
  S X=$P(DIKZ("M"),U,1)
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y X ^DD(399,232,1,1,1.1) X ^DD(399,232,1,1,1.4)
+ S X=$P(DIKZ("U2"),U,10)
  I X'="" D
  .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X=DIV S X=$$PRVQUAL^IBCU(DA,X,1) X ^DD(399,101,1,4,1.4)
+ S DIKZ("M")=$G(^DGCR(399,DA,"M"))
+ S X=$P(DIKZ("M"),U,2)
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$CLIAREQ^IBCEP8A(DA) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$CLIA^IBCEP8A(DA) X ^DD(399,232,1,3,1.4)
+ S X=$P(DIKZ("U2"),U,10)
  I X'="" D
  .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,X,2) X ^DD(399,102,1,2,1.4)
+ S X=$P(DIKZ("M"),U,2)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $$COBN^IBCEF(DA)=2 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y X ^DD(399,102,1,3,1.1) X ^DD(399,102,1,3,1.4)
+ S X=$P(DIKZ("M"),U,2)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$S($$MCRWNR^IBEFUNC(X):$$COBN^IBCEF(DA)=2,1:0) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X="" X ^DD(399,102,1,4,1.4)
+ S X=$P(DIKZ("M"),U,2)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=$$PRVQUAL^IBCU(DA,X,2) X ^DD(399,102,1,5,1.4)
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U3")):^("U3"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=$P($$TAXGET^IBCEP81(X),U,2) X ^DD(399,232,1,4,1.4)
+ S DIKZ("M1")=$G(^DGCR(399,DA,"M1"))
+ S X=$P(DIKZ("M1"),U,8)
+ I X'="" S ^DGCR(399,"AG",$E(X,1,30),DA)=""
+CR1 S DIXR=139
+ K X
  S DIKZ("M")=$G(^DGCR(399,DA,"M"))
+ S X=$P(DIKZ("M"),U,3)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,X,3) X ^DD(399,103,1,2,1.4)
+ S X=$P(DIKZ("M"),U,3)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV S X=$$PRVQUAL^IBCU(DA,X,3) X ^DD(399,103,1,3,1.4)
+ S X(1)=$P(DIKZ("M"),U,1)
+ S X(2)=$P(DIKZ("M"),U,2)
+ S X(3)=$P(DIKZ("M"),U,3)
+ S X(4)=$P(DIKZ("M"),U,13)
+ S X(5)=$P(DIKZ("M"),U,12)
+ S X(6)=$P(DIKZ("M"),U,14)
+ S X=$G(X(1))
+ D
+ . K X1,X2 M X1=X,X2=X
+ . N DIKXARR M DIKXARR=X S DIKCOND=1
+ . S X=$S($O(^DGCR(399,DA,"PRV",0)):1,1:0)
+ . S DIKCOND=$G(X) K X M X=DIKXARR
+ . Q:'DIKCOND
+ . D:X1(1)'=X2(1)!(X1(5)'=X2(5)) SETID^IBCEP3(DA,1) D:X1(2)'=X2(2)!(X1(4)'=X2(4)) SETID^IBCEP3(DA,2) D:X1(3)'=X2(3)!(X1(6)'=X2(6)) SETID^IBCEP3(DA,3)
+CR2 S DIXR=430
+ K X
  S DIKZ("M")=$G(^DGCR(399,DA,"M"))
+ S X=$P(DIKZ("M"),U,11)
+ I X'="" D MAILIN^IBCU5
+ S X=$P(DIKZ("M"),U,11)
+ I X'="" S DGRVRCAL=1
+ S X=$P(DIKZ("M"),U,12)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y X ^DD(399,112,1,1,1.1) X ^DD(399,112,1,1,1.4)
+ S X=$P(DIKZ("M"),U,12)
+ I X'="" D IX^IBCNS2(DA,"I1")
+ S X=$P(DIKZ("M"),U,12)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,112,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$BPP^IBCNS2(DA,1) X ^DD(399,112,1,3,1.4)
+ S DIKZ("M")=$G(^DGCR(399,DA,"M"))
+ S X=$P(DIKZ("M"),U,13)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y X ^DD(399,113,1,1,1.1) X ^DD(399,113,1,1,1.4)
+ S X=$P(DIKZ("M"),U,13)
+ I X'="" D IX^IBCNS2(DA,"I2")
+ S X=$P(DIKZ("M"),U,13)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,113,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$BPP^IBCNS2(DA,1) X ^DD(399,113,1,3,1.4)
+ S DIKZ("M")=$G(^DGCR(399,DA,"M"))
+ S X=$P(DIKZ("M"),U,14)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y X ^DD(399,114,1,1,1.1) X ^DD(399,114,1,1,1.4)
+ S X=$P(DIKZ("M"),U,14)
+ I X'="" D IX^IBCNS2(DA,"I3")
+ S X=$P(DIKZ("M"),U,14)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,114,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$BPP^IBCNS2(DA) X ^DD(399,114,1,3,1.4)
+ S DIKZ("MP")=$G(^DGCR(399,DA,"MP"))
+ S X=$P(DIKZ("MP"),U,1)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,19),X=X S DIU=X K Y S X=DIV S X=$$FT^IBCU3(DA,1) X ^DD(399,135,1,2,1.4)
+ S X=$P(DIKZ("MP"),U,1)
+ I X'="" D MAILA^IBCU5
+ S X=$P(DIKZ("MP"),U,1)
+ I X'="" S DGRVRCAL=1
+ S DIKZ("MP")=$G(^DGCR(399,DA,"MP"))
+ S X=$P(DIKZ("MP"),U,2)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$WNRBILL^IBEFUNC(DA) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y X ^DD(399,136,1,1,1.1) X ^DD(399,136,1,1,1.4)
+ S DIKZ("U")=$G(^DGCR(399,DA,"U"))
+ S X=$P(DIKZ("U"),U,1)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,151,1,1,1.4)
+ S X=$P(DIKZ("U"),U,1)
+ I X'="" S DGRVRCAL=1
+ S X=$P(DIKZ("U"),U,1)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I +$G(^DGCR(399,DA,"U1"))=0 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X=0 X ^DD(399,151,1,3,1.4)
+ S X=$P(DIKZ("U"),U,1)
+ I X'="" S:$P(^DGCR(399,DA,0),"^",2) ^DGCR(399,"APDS",$P(^(0),U,2),-X,DA)=""
+ S DIKZ("U")=$G(^DGCR(399,DA,"U"))
+ S X=$P(DIKZ("U"),U,2)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,152,1,1,1.4)
+ S X=$P(DIKZ("U"),U,2)
+ I X'="" S DGRVRCAL=1
+ S DIKZ("U")=$G(^DGCR(399,DA,"U"))
+ S X=$P(DIKZ("U"),U,11)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,161,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV D DIS^IBCU S X=X S DIH=$G(^DGCR(399,DIV(0),"U")),DIV=X S $P(^("U"),U,12)=DIV,DIH=399,DIG=162 D ^DICR
+ S DIKZ("U")=$G(^DGCR(399,DA,"U"))
+ S X=$P(DIKZ("U"),U,15)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=($P($G(^DGCR(399,DA,"U2")),U,2)=""&$$INPAT^IBCEF(DA,1)) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIV X ^DD(399,165,1,1,1.4)
+ S X=$P(DIKZ("U"),U,15)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,165,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV N Z S X=$$LOS1^IBCU64(DA,.Z),X=+$G(Z) X ^DD(399,165,1,2,1.4)
+ S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
+ S X=$P(DIKZ("U2"),U,4)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,218,1,1,1.4)
+ S X=$P(DIKZ("U2"),U,4)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="PRIOR PAYMENT(S)" X ^DD(399,218,1,2,1.4)
+ S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
+ S X=$P(DIKZ("U2"),U,5)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,219,1,1,1.4)
+ S X=$P(DIKZ("U2"),U,5)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="PRIOR PAYMENT(S)" X ^DD(399,219,1,2,1.4)
+ S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
+ S X=$P(DIKZ("U2"),U,6)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,220,1,1,1.4)
+ S X=$P(DIKZ("U2"),U,6)
+ S X(1)=$P(DIKZ("M"),U,1)
+ S X(2)=$P(DIKZ("M"),U,2)
+ S X(3)=$P(DIKZ("M"),U,3)
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X(4)=$P(DIKZ(0),U,2)
+ S X=$G(X(1))
+ D
+ . K X1,X2 M X1=X,X2=X
+ . N CURR S CURR=+$$COBN^IBCEF(DA) I $G(X(4)),$G(X(CURR)) S ^DGCR(399,"AE",X(4),X(CURR),DA)=""
+CR3 K X
 END G ^IBXX18

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX18.m

-              r628
+              r636
 IBXX18 ; COMPILED XREF FOR FILE #399.0222 ; 07/22/08
+IBXX18 ; COMPILED XREF FOR FILE #399.0222 ; 12/27/07
+ ;
+ S DA(1)=DA S DA=0
+A1 ;
+ I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1
+;
+A S DA=$O(^DGCR(399,DA(1),"PRV",DA)) I DA'>0 S DA=0 G END
+;
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"PRV",DA,0))
+ S X=$P(DIKZ(0),U,1)
+ I X'="" S ^DGCR(399,DA(1),"PRV","B",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,1)
  I X'="" D
  .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="PRIOR PAYMENT(S)" X ^DD(399,220,1,2,1.4)
+ S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
+ S X=$P(DIKZ("U2"),U,10)
+ .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(0)=X S X=Y(0),X=X S X=X'=1 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"PRV",D1,0)):^(0),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(399.0222,.01,1,2,1.4)
+ S X=$P(DIKZ(0),U,1)
+ I X'="" S ^DGCR(399,DA(1),"PRV","C",$E($$EXTERNAL^DILFD(399.0222,.01,,X),1,30),DA)=""
+ S X=$P(DIKZ(0),U,1)
+ I X'="" S ^DGCR(399,DA(1),"PRV","C",$$LOW^XLFSTR($E($$EXTERNAL^DILFD(399.0222,.01,,X),1,30)),DA)=""
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"PRV",DA,0))
+ S X=$P(DIKZ(0),U,2)
  I X'="" D
  .N DIK,DIV,DIU,DIN
  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y X ^DD(399,232,1,1,1.1) X ^DD(399,232,1,1,1.4)
  S X=$P(DIKZ("U2"),U,10)
+ .X ^DD(399.0222,.02,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"PRV",D1,0)):^(0),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X="" X ^DD(399.0222,.02,1,1,1.4)
+ S X=$P(DIKZ(0),U,2)
  I X'="" D
  .N DIK,DIV,DIU,DIN
  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$CLIAREQ^IBCEP8A(DA) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$CLIA^IBCEP8A(DA) X ^DD(399,232,1,3,1.4)
  S X=$P(DIKZ("U2"),U,10)
+ .X ^DD(399.0222,.02,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"PRV",D1,0)):^(0),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=$$EXTCR^IBCEU5(X) X ^DD(399.0222,.02,1,2,1.4)
+ S X=$P(DIKZ(0),U,2)
  I X'="" D
  .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U3")):^("U3"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=$P($$TAXGET^IBCEP81(X),U,2) X ^DD(399,232,1,4,1.4)
+ S DIKZ("M1")=$G(^DGCR(399,DA,"M1"))
+ S X=$P(DIKZ("M1"),U,8)
+ I X'="" S ^DGCR(399,"AG",$E(X,1,30),DA)=""
+CR1 S DIXR=139
+ K X
+ S DIKZ("M")=$G(^DGCR(399,DA,"M"))
+ S X(1)=$P(DIKZ("M"),U,1)
+ S X(2)=$P(DIKZ("M"),U,2)
+ S X(3)=$P(DIKZ("M"),U,3)
+ S X(4)=$P(DIKZ("M"),U,13)
+ S X(5)=$P(DIKZ("M"),U,12)
+ S X(6)=$P(DIKZ("M"),U,14)
+ S X=$G(X(1))
+ D
+ . K X1,X2 M X1=X,X2=X
+ . N DIKXARR M DIKXARR=X S DIKCOND=1
+ . S X=$S($O(^DGCR(399,DA,"PRV",0)):1,1:0)
+ . S DIKCOND=$G(X) K X M X=DIKXARR
+ . Q:'DIKCOND
+ . D:X1(1)'=X2(1)!(X1(5)'=X2(5)) SETID^IBCEP3(DA,1) D:X1(2)'=X2(2)!(X1(4)'=X2(4)) SETID^IBCEP3(DA,2) D:X1(3)'=X2(3)!(X1(6)'=X2(6)) SETID^IBCEP3(DA,3)
+CR2 S DIXR=477
+ K X
+ S DIKZ("M")=$G(^DGCR(399,DA,"M"))
+ S X(1)=$P(DIKZ("M"),U,1)
+ S X(2)=$P(DIKZ("M"),U,2)
+ S X(3)=$P(DIKZ("M"),U,3)
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X(4)=$P(DIKZ(0),U,2)
+ S X=$G(X(1))
+ D
+ . K X1,X2 M X1=X,X2=X
+ . N CURR S CURR=+$$COBN^IBCEF(DA) I $G(X(4)),$G(X(CURR)) S ^DGCR(399,"AE",X(4),X(CURR),DA)=""
+CR3 K X
+ .X ^DD(399.0222,.02,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"PRV",D1,0)):^(0),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=$$SPEC^IBCEU(X) X ^DD(399.0222,.02,1,3,1.4)
+ S X=$P(DIKZ(0),U,2)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(1)=$S($D(^DGCR(399,D0,"PRV",D1,0)):^(0),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$P($$GETTAX^IBCEF73A(X),U,2) X ^DD(399.0222,.02,1,7,1.4)
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"PRV",DA,0))
+ S X=$P(DIKZ(0),U,5)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(0)=X S X=Y(0)="SLF000" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"PRV",D1,0)):^(0),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(399.0222,.05,1,1,1.4)
+ S X=$P(DIKZ(0),U,5)
+ I X'="" D ATTREND^IBCU1(DA(1),DA,.05)
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"PRV",DA,0))
+ S X=$P(DIKZ(0),U,6)
+ I X'="" D ATTREND^IBCU1(DA(1),DA,.06)
+ S X=$P(DIKZ(0),U,7)
+ I X'="" D ATTREND^IBCU1(DA(1),DA,.07)
+ S X=$P(DIKZ(0),U,12)
+ I X'="" D ATTREND^IBCU1(DA(1),DA,.12)
+ S X=$P(DIKZ(0),U,13)
+ I X'="" D ATTREND^IBCU1(DA(1),DA,.13)
+ S X=$P(DIKZ(0),U,14)
+ I X'="" D ATTREND^IBCU1(DA(1),DA,.14)
+ G:'$D(DIKLM) A Q:$D(DISET)
 END G ^IBXX19

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX19.m

-              r628
+              r636
 IBXX19 ; COMPILED XREF FOR FILE #399.0222 ; 07/22/08
+IBXX19 ; COMPILED XREF FOR FILE #399.0304 ; 12/27/07
+ ;
  S DA(1)=DA S DA=0
+ S DA=0
 A1 ;
  I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1
 ;
 A S DA=$O(^DGCR(399,DA(1),"PRV",DA)) I DA'>0 S DA=0 G END
+A S DA=$O(^DGCR(399,DA(1),"CP",DA)) I DA'>0 S DA=0 G END
 ;
  S DIKZ(0)=$G(^DGCR(399,DA(1),"PRV",DA,0))
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"CP",DA,0))
  S X=$P(DIKZ(0),U,1)
  I X'="" S ^DGCR(399,DA(1),"PRV","B",$E(X,1,30),DA)=""
+ I X'="" S ^DGCR(399,DA(1),"CP","B",$E(X,1,30),DA)=""
  S X=$P(DIKZ(0),U,1)
+ I X'="" I $P(X,";",2)="ICPT(",$D(^DGCR(399,DA(1),"CP",DA,0)),$P(^(0),"^",2) S ^DGCR(399,"ASD",-$P(^(0),"^",2),+X,DA(1),DA)=""
+ S X=$P(DIKZ(0),U,2)
+ I X'="" I $D(^DGCR(399,DA(1),"CP",DA,0)),+^(0),$P($P(^(0),"^",1),";",2)="ICPT(" S ^DGCR(399,"ASD",-X,+^(0),DA(1),DA)=""
+ S X=$P(DIKZ(0),U,4)
+ I X'="" S ^DGCR(399,DA(1),"CP","D",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,5)
+ I X'="" S DGRVRCAL=1
+ S X=$P(DIKZ(0),U,5)
+ I X'="" S ^DGCR(399,DA(1),"CP","ASC",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,7)
  I X'="" D
  .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(0)=X S X=Y(0),X=X S X=X'=1 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"PRV",D1,0)):^(0),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(399.0222,.01,1,2,1.4)
+ S X=$P(DIKZ(0),U,1)
+ I X'="" S ^DGCR(399,DA(1),"PRV","C",$E($$EXTERNAL^DILFD(399.0222,.01,,X),1,30),DA)=""
+ S X=$P(DIKZ(0),U,1)
+ I X'="" S ^DGCR(399,DA(1),"PRV","C",$$LOW^XLFSTR($E($$EXTERNAL^DILFD(399.0222,.01,,X),1,30)),DA)=""
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"PRV",DA,0))
+ S X=$P(DIKZ(0),U,2)
+ .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(1)=$S($D(^DGCR(399,D0,"CP",D1,0)):^(0),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y X ^DD(399.0304,6,1,1,1.1) X ^DD(399.0304,6,1,1,1.4)
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"CP",DA,0))
+ S X=$P(DIKZ(0),U,10)
  I X'="" D
  .N DIK,DIV,DIU,DIN
+ .X ^DD(399.0222,.02,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"PRV",D1,0)):^(0),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X="" X ^DD(399.0222,.02,1,1,1.4)
+ S X=$P(DIKZ(0),U,2)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399.0222,.02,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"PRV",D1,0)):^(0),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=$$EXTCR^IBCEU5(X) X ^DD(399.0222,.02,1,2,1.4)
+ S X=$P(DIKZ(0),U,2)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399.0222,.02,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"PRV",D1,0)):^(0),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=$$SPEC^IBCEU(X) X ^DD(399.0222,.02,1,3,1.4)
+ S X=$P(DIKZ(0),U,2)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(1)=$S($D(^DGCR(399,D0,"PRV",D1,0)):^(0),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$P($$GETTAX^IBCEF73A(X),U,2) X ^DD(399.0222,.02,1,7,1.4)
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"PRV",DA,0))
+ S X=$P(DIKZ(0),U,5)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(0)=X S X=Y(0)="SLF000" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"PRV",D1,0)):^(0),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(399.0222,.05,1,1,1.4)
+ S X=$P(DIKZ(0),U,5)
+ I X'="" D ATTREND^IBCU1(DA(1),DA,.05)
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"PRV",DA,0))
+ S X=$P(DIKZ(0),U,6)
+ I X'="" D ATTREND^IBCU1(DA(1),DA,.06)
+ S X=$P(DIKZ(0),U,7)
+ I X'="" D ATTREND^IBCU1(DA(1),DA,.07)
+ S X=$P(DIKZ(0),U,12)
+ I X'="" D ATTREND^IBCU1(DA(1),DA,.12)
+ S X=$P(DIKZ(0),U,13)
+ I X'="" D ATTREND^IBCU1(DA(1),DA,.13)
+ S X=$P(DIKZ(0),U,14)
+ I X'="" D ATTREND^IBCU1(DA(1),DA,.14)
+ .X ^DD(399.0304,9,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"CP",D1,0)):^(0),1:"") S X=$P(Y(1),U,16),X=X S DIU=X K Y S X="" X ^DD(399.0304,9,1,1,1.4)
  G:'$D(DIKLM) A Q:$D(DISET)
 END G ^IBXX20

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX2.m

-              r628
+              r636
 IBXX2 ; COMPILED XREF FOR FILE #399.0222 ; 07/22/08
+IBXX2 ; COMPILED XREF FOR FILE #399.0222 ; 12/27/07
+ ;
  I X'="" D
 …
  . Q:'DIKCOND
  . D:X1(1)'=X2(1)!(X1(5)'=X2(5)) DELID^IBCEP3(DA,1) D:X1(2)'=X2(2)!(X1(4)'=X2(4)) DELID^IBCEP3(DA,2) D:X1(3)'=X2(3)!(X1(6)'=X2(6)) DELID^IBCEP3(DA,3)
 CR2 S DIXR=477
+CR2 S DIXR=430
  K X
  S DIKZ("M")=$G(^DGCR(399,DA,"M"))

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX20.m

-              r628
+              r636
 IBXX20 ; COMPILED XREF FOR FILE #399.0304 ; 07/22/08
+IBXX20 ; COMPILED XREF FOR FILE #399.041 ; 12/27/07
+ ;
  S DA=0
 …
  I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1
 ;
 A S DA=$O(^DGCR(399,DA(1),"CP",DA)) I DA'>0 S DA=0 G END
+A S DA=$O(^DGCR(399,DA(1),"OC",DA)) I DA'>0 S DA=0 G END
 ;
  S DIKZ(0)=$G(^DGCR(399,DA(1),"CP",DA,0))
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"OC",DA,0))
  S X=$P(DIKZ(0),U,1)
+ I X'="" S ^DGCR(399,DA(1),"CP","B",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,1)
+ I X'="" I $P(X,";",2)="ICPT(",$D(^DGCR(399,DA(1),"CP",DA,0)),$P(^(0),"^",2) S ^DGCR(399,"ASD",-$P(^(0),"^",2),+X,DA(1),DA)=""
+ S X=$P(DIKZ(0),U,2)
+ I X'="" I $D(^DGCR(399,DA(1),"CP",DA,0)),+^(0),$P($P(^(0),"^",1),";",2)="ICPT(" S ^DGCR(399,"ASD",-X,+^(0),DA(1),DA)=""
+ S X=$P(DIKZ(0),U,4)
+ I X'="" S ^DGCR(399,DA(1),"CP","D",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,5)
+ I X'="" S DGRVRCAL=1
+ S X=$P(DIKZ(0),U,5)
+ I X'="" S ^DGCR(399,DA(1),"CP","ASC",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,7)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(1)=$S($D(^DGCR(399,D0,"CP",D1,0)):^(0),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y X ^DD(399.0304,6,1,1,1.1) X ^DD(399.0304,6,1,1,1.4)
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"CP",DA,0))
+ S X=$P(DIKZ(0),U,10)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399.0304,9,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"CP",D1,0)):^(0),1:"") S X=$P(Y(1),U,16),X=X S DIU=X K Y S X="" X ^DD(399.0304,9,1,1,1.4)
+ I X'="" S ^DGCR(399,DA(1),"OC","B",$E(X,1,30),DA)=""
  G:'$D(DIKLM) A Q:$D(DISET)
 END G ^IBXX21

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX21.m

-              r628
+              r636
 IBXX21 ; COMPILED XREF FOR FILE #399.041 ; 07/22/08
+IBXX21 ; COMPILED XREF FOR FILE #399.042 ; 12/27/07
+ ;
  S DA=0
 …
  I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1
 ;
 A S DA=$O(^DGCR(399,DA(1),"OC",DA)) I DA'>0 S DA=0 G END
+A S DA=$O(^DGCR(399,DA(1),"RC",DA)) I DA'>0 S DA=0 G END
 ;
  S DIKZ(0)=$G(^DGCR(399,DA(1),"OC",DA,0))
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"RC",DA,0))
  S X=$P(DIKZ(0),U,1)
+ I X'="" S ^DGCR(399,DA(1),"OC","B",$E(X,1,30),DA)=""
+ I X'="" S ^DGCR(399,DA(1),"RC","B",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,1)
+ I X'="" I $P(^DGCR(399,DA(1),"RC",DA,0),U,5) S ^DGCR(399,DA(1),"RC","ABS",$P(^DGCR(399,DA(1),"RC",DA,0),U,5),$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,2)
+ I X'="" D 21^IBCU2
+ S X=$P(DIKZ(0),U,3)
+ I X'="" D 31^IBCU2
+ S X=$P(DIKZ(0),U,4)
+ I X'="" S DGXRF=1 D TC^IBCU2 K DGXRF
+ S X=$P(DIKZ(0),U,5)
+ I X'="" S ^DGCR(399,DA(1),"RC","ABS",$E(X,1,30),+^DGCR(399,DA(1),"RC",DA,0),DA)=""
+ S X=$P(DIKZ(0),U,6)
+ I X'="" I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC1",$E(X,1,30),DA(1),DA)=""
+ S X=$P(DIKZ(0),U,6)
+ I X'="" I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC2",DA(1),$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,7)
+ I X'="" I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC1",$P(^DGCR(399,DA(1),"RC",DA,0),U,6),DA(1),DA)=""
+ S X=$P(DIKZ(0),U,7)
+ I X'="" I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC2",DA(1),$P(^DGCR(399,DA(1),"RC",DA,0),U,6),DA)=""
+ S X=$P(DIKZ(0),U,15)
+ I X'="" S ^DGCR(399,DA(1),"RC","ACP",$E(X,1,30),DA)=""
  G:'$D(DIKLM) A Q:$D(DISET)
 END G ^IBXX22

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX22.m

-              r628
+              r636
 IBXX22 ; COMPILED XREF FOR FILE #399.042 ; 07/22/08
+IBXX22 ; COMPILED XREF FOR FILE #399.043 ; 12/27/07
+ ;
  S DA=0
 …
  I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1
 ;
 A S DA=$O(^DGCR(399,DA(1),"RC",DA)) I DA'>0 S DA=0 G END
+A S DA=$O(^DGCR(399,DA(1),"OP",DA)) I DA'>0 S DA=0 G END
 ;
  S DIKZ(0)=$G(^DGCR(399,DA(1),"RC",DA,0))
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"OP",DA,0))
  S X=$P(DIKZ(0),U,1)
  I X'="" S ^DGCR(399,DA(1),"RC","B",$E(X,1,30),DA)=""
+ I X'="" S ^DGCR(399,"AOPV",$P(^DGCR(399,DA(1),0),U,2),$E(X,1,30),DA(1))=""
  S X=$P(DIKZ(0),U,1)
+ I X'="" I $P(^DGCR(399,DA(1),"RC",DA,0),U,5) S ^DGCR(399,DA(1),"RC","ABS",$P(^DGCR(399,DA(1),"RC",DA,0),U,5),$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,2)
+ I X'="" D 21^IBCU2
+ S X=$P(DIKZ(0),U,3)
+ I X'="" D 31^IBCU2
+ S X=$P(DIKZ(0),U,4)
+ I X'="" S DGXRF=1 D TC^IBCU2 K DGXRF
+ S X=$P(DIKZ(0),U,5)
+ I X'="" S ^DGCR(399,DA(1),"RC","ABS",$E(X,1,30),+^DGCR(399,DA(1),"RC",DA,0),DA)=""
+ S X=$P(DIKZ(0),U,6)
+ I X'="" I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC1",$E(X,1,30),DA(1),DA)=""
+ S X=$P(DIKZ(0),U,6)
+ I X'="" I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC2",DA(1),$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,7)
+ I X'="" I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC1",$P(^DGCR(399,DA(1),"RC",DA,0),U,6),DA(1),DA)=""
+ S X=$P(DIKZ(0),U,7)
+ I X'="" I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC2",DA(1),$P(^DGCR(399,DA(1),"RC",DA,0),U,6),DA)=""
+ S X=$P(DIKZ(0),U,15)
+ I X'="" S ^DGCR(399,DA(1),"RC","ACP",$E(X,1,30),DA)=""
+ I X'="" S DGRVRCAL=1
  G:'$D(DIKLM) A Q:$D(DISET)
 END G ^IBXX23

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX23.m

-              r628
+              r636
 IBXX23 ; COMPILED XREF FOR FILE #399.043 ; 07/22/08
+IBXX23 ; COMPILED XREF FOR FILE #399.044 ; 12/27/07
+ ;
  S DA=0
 …
  I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1
 ;
 A S DA=$O(^DGCR(399,DA(1),"OP",DA)) I DA'>0 S DA=0 G END
+A S DA=$O(^DGCR(399,DA(1),"D1",DA)) I DA'>0 S DA=0 G END
 ;
  S DIKZ(0)=$G(^DGCR(399,DA(1),"OP",DA,0))
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"D1",DA,0))
  S X=$P(DIKZ(0),U,1)
+ I X'="" S ^DGCR(399,"AOPV",$P(^DGCR(399,DA(1),0),U,2),$E(X,1,30),DA(1))=""
+ S X=$P(DIKZ(0),U,1)
+ I X'="" S DGRVRCAL=1
+ I X'="" S ^DGCR(399,DA(1),"D1","B",$E(X,1,30),DA)=""
  G:'$D(DIKLM) A Q:$D(DISET)
 END G ^IBXX24

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX24.m

-              r628
+              r636
 IBXX24 ; COMPILED XREF FOR FILE #399.044 ; 07/22/08
+IBXX24 ; COMPILED XREF FOR FILE #399.045 ; 12/27/07
+ ;
  S DA=0
 …
  I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1
 ;
 A S DA=$O(^DGCR(399,DA(1),"D1",DA)) I DA'>0 S DA=0 G END
+A S DA=$O(^DGCR(399,DA(1),"D2",DA)) I DA'>0 S DA=0 G END
 ;
  S DIKZ(0)=$G(^DGCR(399,DA(1),"D1",DA,0))
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"D2",DA,0))
  S X=$P(DIKZ(0),U,1)
  I X'="" S ^DGCR(399,DA(1),"D1","B",$E(X,1,30),DA)=""
+ I X'="" S ^DGCR(399,DA(1),"D2","B",$E(X,1,30),DA)=""
  G:'$D(DIKLM) A Q:$D(DISET)
 END G ^IBXX25

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX25.m

-              r628
+              r636
 IBXX25 ; COMPILED XREF FOR FILE #399.045 ; 07/22/08
+IBXX25 ; COMPILED XREF FOR FILE #399.046 ; 12/27/07
+ ;
  S DA=0
 …
  I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1
 ;
 A S DA=$O(^DGCR(399,DA(1),"D2",DA)) I DA'>0 S DA=0 G END
+A S DA=$O(^DGCR(399,DA(1),"R",DA)) I DA'>0 S DA=0 G END
 ;
  S DIKZ(0)=$G(^DGCR(399,DA(1),"D2",DA,0))
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"R",DA,0))
  S X=$P(DIKZ(0),U,1)
+ I X'="" S ^DGCR(399,DA(1),"D2","B",$E(X,1,30),DA)=""
+ I X'="" S ^DGCR(399,DA(1),"R","B",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,4)
+ I X'="" S ^DGCR(399,DA(1),"R","AC",$E(X,1,30),DA)=""
  G:'$D(DIKLM) A Q:$D(DISET)
 END G ^IBXX26

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX26.m

-              r628
+              r636
 IBXX26 ; COMPILED XREF FOR FILE #399.046 ; 07/22/08
+IBXX26 ; COMPILED XREF FOR FILE #399.047 ; 12/27/07
+ ;
  S DA=0
 …
  I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1
 ;
 A S DA=$O(^DGCR(399,DA(1),"R",DA)) I DA'>0 S DA=0 G END
+A S DA=$O(^DGCR(399,DA(1),"CV",DA)) I DA'>0 S DA=0 G END
 ;
  S DIKZ(0)=$G(^DGCR(399,DA(1),"R",DA,0))
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"CV",DA,0))
  S X=$P(DIKZ(0),U,1)
+ I X'="" S ^DGCR(399,DA(1),"R","B",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,4)
+ I X'="" S ^DGCR(399,DA(1),"R","AC",$E(X,1,30),DA)=""
+ I X'="" S ^DGCR(399,DA(1),"CV","B",$E(X,1,30),DA)=""
  G:'$D(DIKLM) A Q:$D(DISET)
 END G ^IBXX27

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX27.m

-              r628
+              r636
 IBXX27 ; COMPILED XREF FOR FILE #399.047 ; 07/22/08
+IBXX27 ; COMPILED XREF FOR FILE #399.048 ; 12/27/07
+ ;
  S DA=0
 …
  I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1
 ;
 A S DA=$O(^DGCR(399,DA(1),"CV",DA)) I DA'>0 S DA=0 G END
+A S DA=$O(^DGCR(399,DA(1),"OT",DA)) I DA'>0 S DA=0 G END
 ;
  S DIKZ(0)=$G(^DGCR(399,DA(1),"CV",DA,0))
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"OT",DA,0))
  S X=$P(DIKZ(0),U,1)
  I X'="" S ^DGCR(399,DA(1),"CV","B",$E(X,1,30),DA)=""
+ I X'="" S ^DGCR(399,DA(1),"OT","B",$E(X,1,30),DA)=""
  G:'$D(DIKLM) A Q:$D(DISET)
 END G ^IBXX28

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX28.m

-              r628
+              r636
 IBXX28 ; COMPILED XREF FOR FILE #399.048 ; 07/22/08
+IBXX28 ; COMPILED XREF FOR FILE #399.30416 ; 12/27/07
+ ;
  S DA=0
+ S DA(2)=DA(1) S DA(1)=0 S DA=0
 A1 ;
+ I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1
+;
+A S DA=$O(^DGCR(399,DA(1),"OT",DA)) I DA'>0 S DA=0 G END
+ I $D(DISET) K DIKLM S:DIKM1=2 DIKLM=1 S:DIKM1'=2&'$G(DIKPUSH(2)) DIKPUSH(2)=1,DA(2)=DA(1),DA(1)=DA,DA=0 G @DIKM1
+A S DA(1)=$O(^DGCR(399,DA(2),"CP",DA(1))) I DA(1)'>0 S DA(1)=0 G END
 ;
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"OT",DA,0))
+B S DA=$O(^DGCR(399,DA(2),"CP",DA(1),"MOD",DA)) I DA'>0 S DA=0 Q:DIKM1=1  G A
+;
+ S DIKZ(0)=$G(^DGCR(399,DA(2),"CP",DA(1),"MOD",DA,0))
  S X=$P(DIKZ(0),U,1)
+ I X'="" S ^DGCR(399,DA(1),"OT","B",$E(X,1,30),DA)=""
+ G:'$D(DIKLM) A Q:$D(DISET)
+END G ^IBXX29
+ I X'="" S ^DGCR(399,DA(2),"CP",DA(1),"MOD","B",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,2)
+ I X'="" S ^DGCR(399,DA(2),"CP",DA(1),"MOD","C",$E(X,1,30),DA)=""
+ G:'$D(DIKLM) B Q:$D(DISET)
+END Q

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX3.m

r628	r636
1		IBXX3 ; COMPILED XREF FOR FILE #399.0222 ; ~~07/22/08~~
	1	IBXX3 ; COMPILED XREF FOR FILE #399.0222 ; 12/27/07
2	2	;
3	3	S DA(1)=DA S DA=0

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX4.m

r628	r636
1		IBXX4 ; COMPILED XREF FOR FILE #399.0304 ; ~~07/22/08~~
	1	IBXX4 ; COMPILED XREF FOR FILE #399.0304 ; 12/27/07
2	2	;
3	3	S DA=0

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX5.m

r628	r636
1		IBXX5 ; COMPILED XREF FOR FILE #399.041 ; ~~07/22/08~~
	1	IBXX5 ; COMPILED XREF FOR FILE #399.041 ; 12/27/07
2	2	;
3	3	S DA=0

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX6.m

r628	r636
1		IBXX6 ; COMPILED XREF FOR FILE #399.042 ; ~~07/22/08~~
	1	IBXX6 ; COMPILED XREF FOR FILE #399.042 ; 12/27/07
2	2	;
3	3	S DA=0

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX7.m

r628	r636
1		IBXX7 ; COMPILED XREF FOR FILE #399.043 ; ~~07/22/08~~
	1	IBXX7 ; COMPILED XREF FOR FILE #399.043 ; 12/27/07
2	2	;
3	3	S DA=0

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX8.m

r628	r636
1		IBXX8 ; COMPILED XREF FOR FILE #399.044 ; ~~07/22/08~~
	1	IBXX8 ; COMPILED XREF FOR FILE #399.044 ; 12/27/07
2	2	;
3	3	S DA=0

FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX9.m

r628	r636
1		IBXX9 ; COMPILED XREF FOR FILE #399.045 ; ~~07/22/08~~
	1	IBXX9 ; COMPILED XREF FOR FILE #399.045 ; 12/27/07
2	2	;
3	3	S DA=0

Context Navigation

Legend: