- 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 Mar 13, 2025@21:23 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))
