IBJD1 ;ALB/MR - DIAGNOSTIC MEASURES UTILITIES ;16-DEC-00
;;2.0;INTEGRATED BILLING;**123,159**;21-MAR-94
;
VA(DFN) ; - Is patient a VA employee?
; Input: DFN - Pointer to the Patient file
; IBEXCEL - Optional global Variable (Print to an Excel format)
; Output: VAEMP - "E" (if IBEXCEL) or "*" - VA employee
;
N ELMD,IEN,SSN,VADM,VAEMP
S VAEMP="" G:'$G(DFN) VAQ
D DEM^VADPT S SSN=+$P(VADM(2),"^") G:'SSN VAQ
S IEN=+$O(^PRSPC("SSN",SSN,0)) G:'IEN VAQ
I $P($G(^PRSPC(IEN,1)),U,33)'="Y" S VAEMP=$S($G(IBEXCEL):"E",1:"*")
;
VAQ Q VAEMP
;
PYMT(X) ; - Return most recent bill payment.
; Input: X=Bill pointer to file #399/#430
; Output: Y=Payment date in Fileman format ^ Payment amount
;
N X1,X2,X3,Y S Y="" G:'$G(X) PAYQ
S X1=9999999
F S X1=$O(^PRCA(433,"C",X,X1),-1) Q:'X1 D Q:Y
. S X2=$G(^PRCA(433,X1,0)),X3=$G(^PRCA(433,X1,1))
. I $P(X2,U,4)'=2 Q ; Not complete.
. I "^2^34^"'[(U_$P(X3,U,2)_U) Q ; Not a payment.
. S Y=$S(X3:+X3,1:$P(X3,U,9)\1)_U_+$P(X3,U,5)
PAYQ Q Y
;
INS(DFN,DTE) ; return the Insurance Company for the Patient on DTE (date)
;
N INS,POL,X,X0,Y
S INS="",X=0
F S X=$O(^DPT(DFN,.312,X)) Q:'X I $D(^(X,0)) D
. S X0=^DPT(DFN,.312,X,0)
. I '$$CHK^IBCNS1(X0,DTE) Q
. S POL(0)=$G(POL(0))+1,POL(X,0)=X0
;
I $G(POL(0))<1 G QINS
I $G(POL(0))=1 S Y=+$O(POL(0))
I $G(POL(0))>1 S Y=$$COB^IBCNS1(.POL)
;
S INS=$P($G(^DIC(36,+POL(Y,0),0)),"^")
;
QINS Q INS
;
DIV(CLM) ; Returns the Medical Center Division for the Claim
; Input: CLM - Pointer to Claim Tracking File (#356)
;Output: DIVision for the Claim
;
N ADM,DIV,ENC,PRSC,PRST,X
;
S DIV=0,X=$G(^IBT(356,CLM,0))
S ENC=+$P(X,"^",4) ; Encounter (Pointer to #409.68)
S ADM=+$P(X,"^",5) ; Admission (Pointer to #405)
;
; Inpatient
I ADM S DIV=+$P($G(^DIC(42,+$P($G(^DGPM(+$G(ADM),0)),U,6),0)),U,11)
;
; Outpatient
I 'DIV,ENC S DIV=$P($$SCE^IBSDU(ENC),"^",11)
;
; If Pharmacy/Prosthetics or no Division found assume Primary Division
QDIV S:'DIV DIV=$$PRIM^VASITE() S:DIV'>0 DIV=0
Q DIV
;
CATTYP(IBBCAT) ; - Break down AR Categories into First or Third party
;
N IBFOTP,IBBTYP,IBCATDA0
S IBFOTP="",IBBTYP=""
I (IBBCAT>2&(IBBCAT<6))!(IBBCAT>23&(IBBCAT<27)) Q IBFOTP
I '$D(^PRCA(430.2,IBBCAT,0)) Q IBFOTP
S IBCATDA0=^PRCA(430.2,IBBCAT,0),IBBTYP=$P(IBCATDA0,"^",6)
S IBFOTP=$S((IBBTYP="P")!(IBBTYP="C"):"F",1:"T")
I IBBCAT=15 S IBFOTP="F" ; Exception:Ex-employee is first party
I IBBCAT=16 S IBFOTP="F" ; Exception:Current Emp. is first party
Q IBFOTP
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJD1 2595 printed Sep 23, 2025@19:58:50 Page 2
IBJD1 ;ALB/MR - DIAGNOSTIC MEASURES UTILITIES ;16-DEC-00
+1 ;;2.0;INTEGRATED BILLING;**123,159**;21-MAR-94
+2 ;
VA(DFN) ; - Is patient a VA employee?
+1 ; Input: DFN - Pointer to the Patient file
+2 ; IBEXCEL - Optional global Variable (Print to an Excel format)
+3 ; Output: VAEMP - "E" (if IBEXCEL) or "*" - VA employee
+4 ;
+5 NEW ELMD,IEN,SSN,VADM,VAEMP
+6 SET VAEMP=""
if '$GET(DFN)
GOTO VAQ
+7 DO DEM^VADPT
SET SSN=+$PIECE(VADM(2),"^")
if 'SSN
GOTO VAQ
+8 SET IEN=+$ORDER(^PRSPC("SSN",SSN,0))
if 'IEN
GOTO VAQ
+9 IF $PIECE($GET(^PRSPC(IEN,1)),U,33)'="Y"
SET VAEMP=$SELECT($GET(IBEXCEL):"E",1:"*")
+10 ;
VAQ QUIT VAEMP
+1 ;
PYMT(X) ; - Return most recent bill payment.
+1 ; Input: X=Bill pointer to file #399/#430
+2 ; Output: Y=Payment date in Fileman format ^ Payment amount
+3 ;
+4 NEW X1,X2,X3,Y
SET Y=""
if '$GET(X)
GOTO PAYQ
+5 SET X1=9999999
+6 FOR
SET X1=$ORDER(^PRCA(433,"C",X,X1),-1)
if 'X1
QUIT
Begin DoDot:1
+7 SET X2=$GET(^PRCA(433,X1,0))
SET X3=$GET(^PRCA(433,X1,1))
+8 ; Not complete.
IF $PIECE(X2,U,4)'=2
QUIT
+9 ; Not a payment.
IF "^2^34^"'[(U_$PIECE(X3,U,2)_U)
QUIT
+10 SET Y=$SELECT(X3:+X3,1:$PIECE(X3,U,9)\1)_U_+$PIECE(X3,U,5)
End DoDot:1
if Y
QUIT
PAYQ QUIT Y
+1 ;
INS(DFN,DTE) ; return the Insurance Company for the Patient on DTE (date)
+1 ;
+2 NEW INS,POL,X,X0,Y
+3 SET INS=""
SET X=0
+4 FOR
SET X=$ORDER(^DPT(DFN,.312,X))
if 'X
QUIT
IF $DATA(^(X,0))
Begin DoDot:1
+5 SET X0=^DPT(DFN,.312,X,0)
+6 IF '$$CHK^IBCNS1(X0,DTE)
QUIT
+7 SET POL(0)=$GET(POL(0))+1
SET POL(X,0)=X0
End DoDot:1
+8 ;
+9 IF $GET(POL(0))<1
GOTO QINS
+10 IF $GET(POL(0))=1
SET Y=+$ORDER(POL(0))
+11 IF $GET(POL(0))>1
SET Y=$$COB^IBCNS1(.POL)
+12 ;
+13 SET INS=$PIECE($GET(^DIC(36,+POL(Y,0),0)),"^")
+14 ;
QINS QUIT INS
+1 ;
DIV(CLM) ; Returns the Medical Center Division for the Claim
+1 ; Input: CLM - Pointer to Claim Tracking File (#356)
+2 ;Output: DIVision for the Claim
+3 ;
+4 NEW ADM,DIV,ENC,PRSC,PRST,X
+5 ;
+6 SET DIV=0
SET X=$GET(^IBT(356,CLM,0))
+7 ; Encounter (Pointer to #409.68)
SET ENC=+$PIECE(X,"^",4)
+8 ; Admission (Pointer to #405)
SET ADM=+$PIECE(X,"^",5)
+9 ;
+10 ; Inpatient
+11 IF ADM
SET DIV=+$PIECE($GET(^DIC(42,+$PIECE($GET(^DGPM(+$GET(ADM),0)),U,6),0)),U,11)
+12 ;
+13 ; Outpatient
+14 IF 'DIV
IF ENC
SET DIV=$PIECE($$SCE^IBSDU(ENC),"^",11)
+15 ;
+16 ; If Pharmacy/Prosthetics or no Division found assume Primary Division
QDIV if 'DIV
SET DIV=$$PRIM^VASITE()
if DIV'>0
SET DIV=0
+1 QUIT DIV
+2 ;
CATTYP(IBBCAT) ; - Break down AR Categories into First or Third party
+1 ;
+2 NEW IBFOTP,IBBTYP,IBCATDA0
+3 SET IBFOTP=""
SET IBBTYP=""
+4 IF (IBBCAT>2&(IBBCAT<6))!(IBBCAT>23&(IBBCAT<27))
QUIT IBFOTP
+5 IF '$DATA(^PRCA(430.2,IBBCAT,0))
QUIT IBFOTP
+6 SET IBCATDA0=^PRCA(430.2,IBBCAT,0)
SET IBBTYP=$PIECE(IBCATDA0,"^",6)
+7 SET IBFOTP=$SELECT((IBBTYP="P")!(IBBTYP="C"):"F",1:"T")
+8 ; Exception:Ex-employee is first party
IF IBBCAT=15
SET IBFOTP="F"
+9 ; Exception:Current Emp. is first party
IF IBBCAT=16
SET IBFOTP="F"
+10 QUIT IBFOTP
