IBCNSU4 ;ALB/CPM - SPONSOR UTILITIES ; 21-JAN-97
;;Version 2.0 ; INTEGRATED BILLING ;**52**; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
GET(DFN,ARR) ; Retrieve sponsor relationships for a patient.
; Input: DFN -- Pointer to the patient in file #2
; Output: ARR -- Passed by reference:
;
; ARR = #, where # is the number of relationships
;
; ARR(#,"REL")=1^2^3^4^5, where
; 1 => sponsor name
; 2 => family prefix
; 3 => type (tricare/champva)
; 4 => effective date (fm format)
; 5 => expiration date (fm format)
; 6 => pointer to the relationship in file #355.81
;
; ARR(#,"SPON")=1^2^3^4^5^6, where
; 1 => sponsor name
; 2 => sponsor dob (external format)
; 3 => sponsor ssn (external format [dashes])
; 4 => military status (active duty/retired)
; 5 => branch (expanded from file #23)
; 6 => rank
;
N BRAN,REL,SPON,STAT,X,X1,XSPON,Y,Y1
K ARR S ARR=0
I '$G(DFN) G GETQ
;
; - look at all of the patient's sponsor relationships
S X=0 F S X=$O(^IBA(355.81,"B",DFN,X)) Q:'X D
.S REL=$G(^IBA(355.81,X,0)) Q:'REL
.S SPON=$G(^IBA(355.8,+$P(REL,"^",2),0)) Q:'SPON
.I $L(REL,"^")<6 S REL=REL_"^^^^^^^"
.;
.; - if the sponsor is a patient, gather attributes from file #2
.I $P(SPON,"^")["DPT" D
..S X1=$G(^DPT(+SPON,0))
..S Y=$P(X1,"^",3) X ^DD("DD")
..S XSPON=$P(X1,"^")_"^"_Y_"^"_$$SSN($P(X1,"^",9))
.;
.; - if the sponsor is not a patient, go to file #355.82
.E D
..S XSPON=$G(^IBA(355.82,+SPON,0)) S:$L(XSPON,"^")<3 XSPON=XSPON_"^^"
..S Y=$P(XSPON,"^",2) I Y X ^DD("DD") S $P(XSPON,"^",2)=Y
..S Y=$P(XSPON,"^",3) I Y S $P(XSPON,"^",3)=$$SSN(Y)
.;
.;
.; - build sponsor relation array
.S $P(REL,"^",4)=$S($P(REL,"^",4)="T":"TRICARE",$P(REL,"^",4)="C":"CHAMPVA",1:"")
.S ARR=ARR+1,ARR(ARR,"REL")=$P(XSPON,"^")_"^"_$P(REL,"^",3,6)_"^"_X
.;
.; - build sponsor array
.S STAT=$S($P(SPON,"^",2)="A":"ACTIVE DUTY",$P(SPON,"^",2)="R":"RETIRED",1:"")
.S BRAN=$P($G(^DIC(23,+$P(SPON,"^",3),0)),"^")
.S ARR(ARR,"SPON")=$P(XSPON,"^",1,3)_"^"_STAT_"^"_BRAN_"^"_$P(SPON,"^",4)
;
GETQ Q
;
;
SSN(X) ; Strip dashes from SSN and add them back in.
S:$G(X)'="" X=$TR(X,"-","")
Q $S($G(X)="":"",1:$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,13))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSU4 2608 printed Oct 16, 2024@18:18:41 Page 2
IBCNSU4 ;ALB/CPM - SPONSOR UTILITIES ; 21-JAN-97
+1 ;;Version 2.0 ; INTEGRATED BILLING ;**52**; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
GET(DFN,ARR) ; Retrieve sponsor relationships for a patient.
+1 ; Input: DFN -- Pointer to the patient in file #2
+2 ; Output: ARR -- Passed by reference:
+3 ;
+4 ; ARR = #, where # is the number of relationships
+5 ;
+6 ; ARR(#,"REL")=1^2^3^4^5, where
+7 ; 1 => sponsor name
+8 ; 2 => family prefix
+9 ; 3 => type (tricare/champva)
+10 ; 4 => effective date (fm format)
+11 ; 5 => expiration date (fm format)
+12 ; 6 => pointer to the relationship in file #355.81
+13 ;
+14 ; ARR(#,"SPON")=1^2^3^4^5^6, where
+15 ; 1 => sponsor name
+16 ; 2 => sponsor dob (external format)
+17 ; 3 => sponsor ssn (external format [dashes])
+18 ; 4 => military status (active duty/retired)
+19 ; 5 => branch (expanded from file #23)
+20 ; 6 => rank
+21 ;
+22 NEW BRAN,REL,SPON,STAT,X,X1,XSPON,Y,Y1
+23 KILL ARR
SET ARR=0
+24 IF '$GET(DFN)
GOTO GETQ
+25 ;
+26 ; - look at all of the patient's sponsor relationships
+27 SET X=0
FOR
SET X=$ORDER(^IBA(355.81,"B",DFN,X))
if 'X
QUIT
Begin DoDot:1
+28 SET REL=$GET(^IBA(355.81,X,0))
if 'REL
QUIT
+29 SET SPON=$GET(^IBA(355.8,+$PIECE(REL,"^",2),0))
if 'SPON
QUIT
+30 IF $LENGTH(REL,"^")<6
SET REL=REL_"^^^^^^^"
+31 ;
+32 ; - if the sponsor is a patient, gather attributes from file #2
+33 IF $PIECE(SPON,"^")["DPT"
Begin DoDot:2
+34 SET X1=$GET(^DPT(+SPON,0))
+35 SET Y=$PIECE(X1,"^",3)
XECUTE ^DD("DD")
+36 SET XSPON=$PIECE(X1,"^")_"^"_Y_"^"_$$SSN($PIECE(X1,"^",9))
End DoDot:2
+37 ;
+38 ; - if the sponsor is not a patient, go to file #355.82
+39 IF '$TEST
Begin DoDot:2
+40 SET XSPON=$GET(^IBA(355.82,+SPON,0))
if $LENGTH(XSPON,"^")<3
SET XSPON=XSPON_"^^"
+41 SET Y=$PIECE(XSPON,"^",2)
IF Y
XECUTE ^DD("DD")
SET $PIECE(XSPON,"^",2)=Y
+42 SET Y=$PIECE(XSPON,"^",3)
IF Y
SET $PIECE(XSPON,"^",3)=$$SSN(Y)
End DoDot:2
+43 ;
+44 ;
+45 ; - build sponsor relation array
+46 SET $PIECE(REL,"^",4)=$SELECT($PIECE(REL,"^",4)="T":"TRICARE",$PIECE(REL,"^",4)="C":"CHAMPVA",1:"")
+47 SET ARR=ARR+1
SET ARR(ARR,"REL")=$PIECE(XSPON,"^")_"^"_$PIECE(REL,"^",3,6)_"^"_X
+48 ;
+49 ; - build sponsor array
+50 SET STAT=$SELECT($PIECE(SPON,"^",2)="A":"ACTIVE DUTY",$PIECE(SPON,"^",2)="R":"RETIRED",1:"")
+51 SET BRAN=$PIECE($GET(^DIC(23,+$PIECE(SPON,"^",3),0)),"^")
+52 SET ARR(ARR,"SPON")=$PIECE(XSPON,"^",1,3)_"^"_STAT_"^"_BRAN_"^"_$PIECE(SPON,"^",4)
End DoDot:1
+53 ;
GETQ QUIT
+1 ;
+2 ;
SSN(X) ; Strip dashes from SSN and add them back in.
+1 if $GET(X)'=""
SET X=$TRANSLATE(X,"-","")
+2 QUIT $SELECT($GET(X)="":"",1:$EXTRACT(X,1,3)_"-"_$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,13))
