Index: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF75.m
===================================================================
--- WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF75.m	(revision 613)
+++ WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF75.m	(revision 623)
@@ -1,158 +1,158 @@
-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.
-	;
-	G AWAY
-AWAY	Q
-	;
-ALLIDS(IBIFN,IBXSAVE,IBSTRIP,SEG)	; Return all of the Provider IDS 
-	I '$D(IBSTRIP) S IBSTRIP=0
-	I '$D(SEG) S SEG=""
-	N IBXIEN,ARINFO,ARID,ARQ,IBFRMTYP,ARIEN,ARINS,Z0,DAT,I,SORT1,SORT2,SORT3,COB,IBCCOB
-	;
-	S IBXIEN=IBIFN
-	D ALLPROV^IBCEF7    ; Get the Person ID's (Returns IBXSAVE)
-	S DAT=$$PROVID^IBCEF73(IBIFN)
-	S DAT("QUAL")=IBXSAVE("ID")  ; this value was also passed back by above function
-	S SORT1="" F  S SORT1=$O(IBXSAVE("PROVINF",IBIFN,SORT1)) Q:SORT1=""  D
-	. S SORT2=0 F  S SORT2=$O(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2)) Q:SORT2=""  D
-	.. S SORT3=0 F  S SORT3=$O(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3))  Q:SORT3=""  D
-	... S IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,0)="PRIMARY"_U_U_$$STRIP^IBCEF76($P(DAT("QUAL"),U,SORT3)_U_$P(DAT,U,SORT3),1,U,IBSTRIP)
-	... F I=1:1 Q:'$D(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,I))  D
-	.... S $P(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,I),U,3,4)=$$STRIP^IBCEF76($P(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,I),U,3,4),1,U,IBSTRIP)
-	;
-	D LFIDS^IBCEF76(IBIFN,.IBXSAVE,IBSTRIP,SEG)   ; Get the Lab/Facility IDs
-	;
-	S IBFRMTYP=$$FT^IBCEF(IBIFN)
-	S ARIEN=$S(IBFRMTYP=2:3,1:4)
-	S IBCCOB=$$COBN^IBCEF(IBIFN)  ; Current Insurance
-	F COB=1:1:3 D
-	. S SORT1=$S(COB=IBCCOB:"C",1:"O")
-	. S SORT2=$S(SORT1="C":1,COB=1:1,COB=2&(IBCCOB=1):1,1:2)
-	. S ARINFO=$G(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,ARIEN,1))
-	. ;
-	. D BPIDS(IBIFN,.IBXSAVE,SORT1,SORT2,COB,IBSTRIP,SEG)
-	Q
-	; 
-BPIDS(IBIFN,IDS,SORT1,SORT2,COB,IBSTRIP,SEG)	; Get all the billing provider IDs and qualifiers from the claim and file 355.92
-	N DAT,IBFRMTYP,IBCARE,IBDIV,IBINS,MAIN,IBCCOB,USED,PLANTYPE,I,CNT,QUAL,ARF,M1,DEF,IDDIV,IBLIMIT,IEN,ID,IB2
-	;
-	S DAT=$G(^DGCR(399,IBIFN,0))
-	S IBFRMTYP=$$FT^IBCEF(IBIFN),IBFRMTYP=$S(IBFRMTYP=2:2,IBFRMTYP=3:1,1:0)
-	S IBCARE=$S($$ISRX^IBCEF1(IBIFN):3,1:0) ;if an Rx refill bill
-	S:IBCARE=0 IBCARE=$$INPAT^IBCEF(IBIFN,1) S:'IBCARE IBCARE=2 ;1-inp,2-out
-	S IBDIV=+$P(DAT,U,22)
-	S MAIN=$$MAIN^IBCEP2B()  ; get the IEN for main Division
-	S IBCCOB=$$COBN^IBCEF(IBIFN)  ; Current Insurance
-	S IBINS=$P($G(^DGCR(399,IBIFN,"I"_COB)),U)
-	Q:IBINS=""
-	;
-	S IDS("BILLING PRV",IBIFN,SORT1,SORT2)=$E("PST",COB)
-	;
-	; Primary ID
-	S IDS("BILLING PRV",IBIFN,SORT1,SORT2,0)=$$STRIP^IBCEF76($$TAXID(),1,U,IBSTRIP)
-	S USED($P(IDS("BILLING PRV",IBIFN,SORT1,SORT2,0),U))=""
-	;
-	; Secondary #1 - This is the ID Emdeon uses for sorting
-	S IDS("BILLING PRV",IBIFN,SORT1,SORT2,1)=$$STRIP^IBCEF76($$BPSID1(IBDIV),1,U,IBSTRIP)
-	S USED($P(IDS("BILLING PRV",IBIFN,SORT1,SORT2,1),U))=""
-	;
-	; Check if this is a plan type which gets no secondary IDs
-	S M1=$G(^DGCR(399,IBIFN,"M1"))
-	; the following check is the current value of the flag, not when the claim was created. 
-	S PLANTYPE=$$POLTYP^IBCEF3(IBIFN,COB)
-	I PLANTYPE]"",$D(^DIC(36,IBINS,13,"B",PLANTYPE)) Q 
-	;
-	; Secondary #2
-	; If there is a ID  send with quailifer (stored or computed)
-	I $TR($P(M1,U,COB+1)," ")]"" D
-	. S QUAL=""
-	. S DAT=$P(M1,U,COB+9)
-	. I DAT S QUAL=$$STRIP^IBCEF76($P($G(^IBE(355.97,DAT,0)),U,3),1,,IBSTRIP)
-	. ; the null check is needed to be backwards compatible
-	. I QUAL=""!(QUAL="1J") S QUAL=$$STRIP^IBCEF76($$OLDWAY(IBIFN,COB),1,,IBSTRIP)
-	. 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)
-	;
-	S IDS("BILLING PRV",IBIFN,SORT1,SORT2,2)=IB2
-	S IDS("BILLING PRV",IBIFN,SORT1,SORT2,2,"PTQ")=$$OLDWAY(IBIFN,COB)
-	S USED($P(IB2,U))=""
-	;
-	S CNT=$S('$D(IDS("BILLING PRV",IBIFN,SORT1,SORT2,2)):2,1:3)
-	S IBLIMIT=8
-	S IEN=0 F  S IEN=$O(^IBA(355.92,"B",IBINS,IEN)) Q:IEN=""  D  Q:CNT>IBLIMIT
-	. S DAT=$G(^IBA(355.92,IEN,0))
-	. Q:$P(DAT,U,8)'="A"   ; only allow additional IDs
-	. Q:$P(DAT,U,7)=""  ; No Provider ID
-	. Q:$P(DAT,U,6)=""  ; No ID Qualifier
-	. I IBFRMTYP=1 Q:$P(DAT,U,4)=2
-	. I IBFRMTYP=2 Q:$P(DAT,U,4)=1
-	. ;
-	. ; Check if we already have one of these
-	. S QUAL=$$STRIP^IBCEF76($P(DAT,U,6),1,,IBSTRIP)
-	. S QUAL=$P($G(^IBE(355.97,QUAL,0)),U,3)
-	. Q:QUAL=""
-	. Q:$D(USED(QUAL))
-	. ;
-	. S IDS("BILLING PRV",IBIFN,SORT1,SORT2,CNT)=QUAL_U_$$STRIP^IBCEF76($P(DAT,U,7),1,,IBSTRIP)
-	. S CNT=CNT+1,USED(QUAL)=""
-	;
-	Q
-	;
-OLDWAY(IBIFN,COB)	; Figure out the qualifier the old way if it's not stored with the claim.
-	; It's based on the plan type.  This is used for Billing Provider Secondary ID #2
-	N PLANTYPE
-	S PLANTYPE=$$POLTYP^IBCEF3(IBIFN,COB)
-	Q $$SOP^IBCEP2B(IBIFN,PLANTYPE)
-	;
-BPSID1(DIV)	; Return the Billing Provider Secondary ID #1 and qualifier which Emdeon uses to sort IBIFNs
-	N DATA
-	S DATA=$P($$SITE^VASITE(DT,$S(DIV:DIV,1:+$$SITE^VASITE())),U,3)
-	S DATA=$E("0000",1,7-$L(DATA))_$E(DATA,4,7)
-	Q "G5"_U_DATA
-	;
-TAXID()	; Return the Billing Provider Primary ID and qualifier which is the TAXID for the site and also the qualifier
-	N DATA
-	S DATA=$P($G(^IBE(350.9,1,1)),U,5)
-	S DATA=$$NOPUNCT^IBCEF(DATA,1)
-	Q 24_U_DATA
-	;
-VAMCFD(IBIFN,IBRET)	;
-	;
-	; This procedure returns data based on flag in insurance company file which is set in the insurance co editor
-	; Send VA Lab/Facility IDs or Facility Data for VAMC?
-	; The return value will be set to 1 (yes) if the division in the claim is not the main division (VAMC) or
-	; if the flag in the dictionary for that insurance company says to send the data.
-	; 
-	; Input - IBFN - IEN 399
-	; Output - IBRET(IBSORT1,IBSORT2)=FLAG
-	;    IBSORT1 = "C"urrent or "O"ther insurance
-	;    IBSORT2 = order with IBSORT1
-	;    FLAG = 0 No or 1 Yes
-	;
-	N IBDIV,MAIN,IBCCOB,IBSORT1,IBSORT2,DAT,IBINS,COB,OUTFAC
-	S IBDIV=+$P($G(^DGCR(399,IBIFN,0)),U,22)
-	S MAIN=$$MAIN^IBCEP2B()  ; get the IEN for main Division
-	S IBCCOB=$$COBN^IBCEF(IBIFN)
-	F COB=1:1:3 D
-	. S IBSORT1=$S(COB=IBCCOB:"C",1:"O")
-	. S IBSORT2=$S(IBSORT1="C":1,COB=1:1,COB=2&(IBCCOB=1):1,1:2)
-	. S IBINS=+$G(^DGCR(399,IBIFN,"I"_COB))
-	. Q:'IBINS
-	. S IBRET(IBSORT1,IBSORT2)=1
-	. S OUTFAC=$P($G(^DGCR(399,IBIFN,"U2")),U,10)
-	. Q:OUTFAC]""
-	. Q:IBDIV'=MAIN
-	. ; [7] Send VA Lab/Facility IDs or Facility Data for VAMC?(0 - NO, 1 - YES)
-	. S DAT(3647)=$P($G(^DIC(36,IBINS,4)),U,7)
-	. I DAT(3647) Q
-	. S IBRET(IBSORT1,IBSORT2)=0
-	Q
-	;
-CLEANUP(IBXSAVE)	; Clean up 
-	K IBXSAVE("PROVINF")
-	K IBXSAVE("LAB/FAC")
-	K IBXSAVE("BILLING PRV")
-	K IBXSAVE("ID")
-	Q
+IBCEF75 ;ALB/WCJ - Provider ID functions ;13 Feb 2006
+ ;;2.0;INTEGRATED BILLING;**320**;21-MAR-94
+ ;; Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
+ G AWAY
+AWAY Q
+ ;
+ALLIDS(IBIFN,IBXSAVE,IBSTRIP,SEG) ; Return all of the Provider IDS 
+ I '$D(IBSTRIP) S IBSTRIP=0
+ I '$D(SEG) S SEG=""
+ N IBXIEN,ARINFO,ARID,ARQ,IBFRMTYP,ARIEN,ARINS,Z0,DAT,I,SORT1,SORT2,SORT3,COB,IBCCOB
+ ;
+ S IBXIEN=IBIFN
+ D ALLPROV^IBCEF7    ; Get the Person ID's (Returns IBXSAVE)
+ S DAT=$$PROVID^IBCEF73(IBIFN)
+ S DAT("QUAL")=IBXSAVE("ID")  ; this value was also passed back by above function
+ S SORT1="" F  S SORT1=$O(IBXSAVE("PROVINF",IBIFN,SORT1)) Q:SORT1=""  D
+ . S SORT2=0 F  S SORT2=$O(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2)) Q:SORT2=""  D
+ .. S SORT3=0 F  S SORT3=$O(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3))  Q:SORT3=""  D
+ ... S IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,0)="PRIMARY"_U_U_$$STRIP^IBCEF76($P(DAT("QUAL"),U,SORT3)_U_$P(DAT,U,SORT3),1,U,IBSTRIP)
+ ... F I=1:1 Q:'$D(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,I))  D
+ .... S $P(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,I),U,3,4)=$$STRIP^IBCEF76($P(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,I),U,3,4),1,U,IBSTRIP)
+ ;
+ D LFIDS^IBCEF76(IBIFN,.IBXSAVE,IBSTRIP,SEG)   ; Get the Lab/Facility IDs
+ ;
+ S IBFRMTYP=$$FT^IBCEF(IBIFN)
+ S ARIEN=$S(IBFRMTYP=2:3,1:4)
+ S IBCCOB=$$COBN^IBCEF(IBIFN)  ; Current Insurance
+ F COB=1:1:3 D
+ . S SORT1=$S(COB=IBCCOB:"C",1:"O")
+ . S SORT2=$S(SORT1="C":1,COB=1:1,COB=2&(IBCCOB=1):1,1:2)
+ . S ARINFO=$G(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,ARIEN,1))
+ . ;
+ . D BPIDS(IBIFN,.IBXSAVE,SORT1,SORT2,COB,IBSTRIP,SEG)
+ Q
+ ; 
+BPIDS(IBIFN,IDS,SORT1,SORT2,COB,IBSTRIP,SEG) ; Get all the billing provider IDs and qualifiers from the claim and file 355.92
+ N DAT,IBFRMTYP,IBCARE,IBDIV,IBINS,MAIN,IBCCOB,USED,PLANTYPE,I,CNT,QUAL,ARF,M1,DEF,IDDIV,IBLIMIT,IEN,ID,IB2
+ ;
+ S DAT=$G(^DGCR(399,IBIFN,0))
+ S IBFRMTYP=$$FT^IBCEF(IBIFN),IBFRMTYP=$S(IBFRMTYP=2:2,IBFRMTYP=3:1,1:0)
+ S IBCARE=$S($$ISRX^IBCEF1(IBIFN):3,1:0) ;if an Rx refill bill
+ S:IBCARE=0 IBCARE=$$INPAT^IBCEF(IBIFN,1) S:'IBCARE IBCARE=2 ;1-inp,2-out
+ S IBDIV=+$P(DAT,U,22)
+ S MAIN=$$MAIN^IBCEP2B()  ; get the IEN for main Division
+ S IBCCOB=$$COBN^IBCEF(IBIFN)  ; Current Insurance
+ S IBINS=$P($G(^DGCR(399,IBIFN,"I"_COB)),U)
+ Q:IBINS=""
+ ;
+ S IDS("BILLING PRV",IBIFN,SORT1,SORT2)=$E("PST",COB)
+ ;
+ ; Primary ID
+ S IDS("BILLING PRV",IBIFN,SORT1,SORT2,0)=$$STRIP^IBCEF76($$TAXID(),1,U,IBSTRIP)
+ S USED($P(IDS("BILLING PRV",IBIFN,SORT1,SORT2,0),U))=""
+ ;
+ ; Secondary #1 - This is the ID Emdeon uses for sorting
+ S IDS("BILLING PRV",IBIFN,SORT1,SORT2,1)=$$STRIP^IBCEF76($$BPSID1(IBDIV),1,U,IBSTRIP)
+ S USED($P(IDS("BILLING PRV",IBIFN,SORT1,SORT2,1),U))=""
+ ;
+ ; Check if this is a plan type which gets no secondary IDs
+ S M1=$G(^DGCR(399,IBIFN,"M1"))
+ ; the following check is the current value of the flag, not when the claim was created. 
+ S PLANTYPE=$$POLTYP^IBCEF3(IBIFN,COB)
+ I PLANTYPE]"",$D(^DIC(36,IBINS,13,"B",PLANTYPE)) Q 
+ ;
+ ; Secondary #2
+ ; If there is a ID  send with quailifer (stored or computed)
+ I $P(M1,U,COB+1)]"" D
+ . S QUAL=""
+ . S DAT=$P(M1,U,COB+9)
+ . I DAT S QUAL=$$STRIP^IBCEF76($P($G(^IBE(355.97,DAT,0)),U,3),1,,IBSTRIP)
+ . ; the null check is needed to be backwards compatible
+ . I QUAL=""!(QUAL="1J") S QUAL=$$STRIP^IBCEF76($$OLDWAY(IBIFN,COB),1,,IBSTRIP)
+ . S IB2=QUAL_U_$$STRIP^IBCEF76($P(M1,U,COB+1),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
+ S IDS("BILLING PRV",IBIFN,SORT1,SORT2,2,"PTQ")=$$OLDWAY(IBIFN,COB)
+ S USED($P(IB2,U))=""
+ ;
+ S CNT=$S('$D(IDS("BILLING PRV",IBIFN,SORT1,SORT2,2)):2,1:3)
+ S IBLIMIT=8
+ S IEN=0 F  S IEN=$O(^IBA(355.92,"B",IBINS,IEN)) Q:IEN=""  D  Q:CNT>IBLIMIT
+ . S DAT=$G(^IBA(355.92,IEN,0))
+ . Q:$P(DAT,U,8)'="A"   ; only allow additional IDs
+ . Q:$P(DAT,U,7)=""  ; No Provider ID
+ . Q:$P(DAT,U,6)=""  ; No ID Qualifier
+ . I IBFRMTYP=1 Q:$P(DAT,U,4)=2
+ . I IBFRMTYP=2 Q:$P(DAT,U,4)=1
+ . ;
+ . ; Check if we already have one of these
+ . S QUAL=$$STRIP^IBCEF76($P(DAT,U,6),1,,IBSTRIP)
+ . S QUAL=$P($G(^IBE(355.97,QUAL,0)),U,3)
+ . Q:QUAL=""
+ . Q:$D(USED(QUAL))
+ . ;
+ . S IDS("BILLING PRV",IBIFN,SORT1,SORT2,CNT)=QUAL_U_$$STRIP^IBCEF76($P(DAT,U,7),1,,IBSTRIP)
+ . S CNT=CNT+1,USED(QUAL)=""
+ ;
+ Q
+ ;
+OLDWAY(IBIFN,COB) ; Figure out the qualifier the old way if it's not stored with the claim.
+ ; It's based on the plan type.  This is used for Billing Provider Secondary ID #2
+ N PLANTYPE
+ S PLANTYPE=$$POLTYP^IBCEF3(IBIFN,COB)
+ Q $$SOP^IBCEP2B(IBIFN,PLANTYPE)
+ ;
+BPSID1(DIV) ; Return the Billing Provider Secondary ID #1 and qualifier which Emdeon uses to sort IBIFNs
+ N DATA
+ S DATA=$P($$SITE^VASITE(DT,$S(DIV:DIV,1:+$$SITE^VASITE())),U,3)
+ S DATA=$E("0000",1,7-$L(DATA))_$E(DATA,4,7)
+ Q "G5"_U_DATA
+ ;
+TAXID() ; Return the Billing Provider Primary ID and qualifier which is the TAXID for the site and also the qualifier
+ N DATA
+ S DATA=$P($G(^IBE(350.9,1,1)),U,5)
+ S DATA=$$NOPUNCT^IBCEF(DATA,1)
+ Q 24_U_DATA
+ ;
+VAMCFD(IBIFN,IBRET) ;
+ ;
+ ; This procedure returns data based on flag in insurance company file which is set in the insurance co editor
+ ; Send VA Lab/Facility IDs or Facility Data for VAMC?
+ ; The return value will be set to 1 (yes) if the division in the claim is not the main division (VAMC) or
+ ; if the flag in the dictionary for that insurance company says to send the data.
+ ; 
+ ; Input - IBFN - IEN 399
+ ; Output - IBRET(IBSORT1,IBSORT2)=FLAG
+ ;    IBSORT1 = "C"urrent or "O"ther insurance
+ ;    IBSORT2 = order with IBSORT1
+ ;    FLAG = 0 No or 1 Yes
+ ;
+ N IBDIV,MAIN,IBCCOB,IBSORT1,IBSORT2,DAT,IBINS,COB,OUTFAC
+ S IBDIV=+$P($G(^DGCR(399,IBIFN,0)),U,22)
+ S MAIN=$$MAIN^IBCEP2B()  ; get the IEN for main Division
+ S IBCCOB=$$COBN^IBCEF(IBIFN)
+ F COB=1:1:3 D
+ . S IBSORT1=$S(COB=IBCCOB:"C",1:"O")
+ . S IBSORT2=$S(IBSORT1="C":1,COB=1:1,COB=2&(IBCCOB=1):1,1:2)
+ . S IBINS=+$G(^DGCR(399,IBIFN,"I"_COB))
+ . Q:'IBINS
+ . S IBRET(IBSORT1,IBSORT2)=1
+ . S OUTFAC=$P($G(^DGCR(399,IBIFN,"U2")),U,10)
+ . Q:OUTFAC]""
+ . Q:IBDIV'=MAIN
+ . ; [7] Send VA Lab/Facility IDs or Facility Data for VAMC?(0 - NO, 1 - YES)
+ . S DAT(3647)=$P($G(^DIC(36,IBINS,4)),U,7)
+ . I DAT(3647) Q
+ . S IBRET(IBSORT1,IBSORT2)=0
+ Q
+ ;
+CLEANUP(IBXSAVE) ; Clean up 
+ K IBXSAVE("PROVINF")
+ K IBXSAVE("LAB/FAC")
+ K IBXSAVE("BILLING PRV")
+ K IBXSAVE("ID")
+ Q
