- IBCVA0 ;ALB/MJB - SET MCCR VARIABLES CONT. ;04 AUG 88 03:02
- ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- ;MAP TO DGCRVA0
- ;
- Q
- ALL I $D(DFN) S IBDPT=^DPT(DFN,0) D ADDR I IBADD1]"",$L(IBADD1)'>47 S DIE="^DGCR(399,",(DA,Y)=+IBIFN,DR="110///"_IBADD1 D ^DIE K DIE,DR,DA
- ;I $D(^DPT(DFN,.11)) S IBST=$P(^(.11),U,5),IBST=$S(IBST'="":$P(^DIC(5,IBST,0),U,2),1:"")
- S IBBNO=$P(IB(0),"^"),IBDT=$P(IB(0),"^",3)
- D 2^VADPT
- ;I $P(IB(0),U,5)<3 S Y=0 F I=1:1 S Y=$O(^DGPM("APTT1",DFN,Y)) Q:'Y S:$E(Y,1,7)=IBDT IBDA=Y
- Q
- 1 ;Demographic variables set
- D Q1^IBCVA
- EN1 Q:'$D(DFN) S IBMAR=$S($P(IBDPT,U,5)'="":$P(IBDPT,U,5),1:"U") I IBMAR'="U" S IBMAR=$S(IBMAR=6:"S",IBMAR=2:"M",IBMAR=1:"D",IBMAR=4:"W",IBMAR=5:"X",1:"U")
- I $D(^DPT(DFN,.121)) S IBTADD=^DPT(DFN,.121),IBTST=$P(IBTADD,U,5),IBTST=$S(IBTST'="":$P(^DIC(5,IBTST,0),U,2),1:"") I $P(IBTADD,U)="" S IBT1="NO TEMPORARY ADDRESS"
- Q
- 2 ;Employment variables set
- D Q1^IBCVA,Q2^IBCVA
- EN2 S:'$D(^DPT(DFN,.311)) IBEMPD="" I $D(^DPT(DFN,.311)) I ^DPT(DFN,.311)'="" S IBEMPD=$P(^(.311),U)_"^"_$P(^(.311),U,6)_"^"_$S($P(^(.311),U,7)'="":$P(^(.311),U,7),1:"")_"^"_$P($G(^DPT(DFN,.22)),U,5)_"^"_$P(IB(0),U,9)_"^"_$P(IB(0),U,8)
- I $D(IBEMPD) S:IBEMPD'="" IBEC=$P(^DPT(DFN,.311),"^",15)
- I $D(^DPT(DFN,.25)) S:$P(^DPT(DFN,.25),U,6)'="" IBSEST=$P(^(.25),U,6),IBSEST=$P(^DIC(5,IBSEST,0),U,2)
- Q
- 3 ;Insurance variables set
- EN3 D 123^IBCVA
- EN31 ; -IBdd(i) = value of ins node in dpt
- I '$D(^DGCR(399,IBIFN,"AIC")) S IBINDT=$S(+$G(IB("U")):+IB("U"),+$G(^DGCR(399,IBIFN,"U")):+$G(^("U")),1:DT) D ALL^IBCNS1(DFN,"IBDD",1,IBINDT) S I="" F S I=$O(IBDD(I)) Q:'I D INS
- I $D(^DGCR(399,IBIFN,"AIC")) S IBIN="I" F I=1:1:3 S IBIN=$O(^DGCR(399,IBIFN,IBIN)) Q:IBIN'?1"I".N S IBDD(I,0)=^DGCR(399,IBIFN,IBIN) D INS
- Q
- INS I '$D(^DGCR(399,IBIFN,"AIC")) S IBISEX(I)=$P(IBDD(I,0),U,6) S:IBISEX(I)="v" IBISEX(I)=$P(^DPT(DFN,0),U,2),IBISEX(I)=$S(IBISEX(I)="M":"MALE",1:"FEMALE")
- I $D(^DGCR(399,IBIFN,"AIC")) S IBISEX(I)=$P(IBDD(I,0),U,6) S:IBISEX(I)="v" IBISEX(I)=$P(^DPT(DFN,0),U,2),IBISEX(I)=$S(IBISEX(I)="M":"MALE",1:"FEMALE")
- S:IBISEX(I)="s" IBISEX(I)=$S($P(VADM(5),U,2)="MALE":"FEMALE",$P(VADM(5),U,2)="FEMALE":"MALE",1:"UNSPECIFIED")
- S:IBISEX(I)="o" IBISEX(I)="UNSPECIFIED"
- 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
- S IBADD1="" I $D(^DGCR(399,IBIFN,"M")),$P(^("M"),"^",10)]"" Q
- S X=$S($D(^DPT(DFN,.11)):^(.11),1:"") F I=1:1:4 I $P(X,"^",I)]"" S IBADD1=IBADD1_$P(X,"^",I)_","
- I $D(^DIC(5,+$P(X,"^",5),0)) S IBADD1=IBADD1_$P(^(0),"^",2),IBST=$P(^(0),"^",2)
- S:$P(X,"^",12)]"" IBADD1=IBADD1_" "_$P(X,"^",12) Q
- ;IBCVA0
- IBCVA0 ;ALB/MJB - SET MCCR VARIABLES CONT. ;04 AUG 88 03:02
- +1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- +4 ;MAP TO DGCRVA0
- +5 ;
- +6 QUIT
- ALL IF $DATA(DFN)
- SET IBDPT=^DPT(DFN,0)
- DO ADDR
- IF IBADD1]""
- IF $LENGTH(IBADD1)'>47
- SET DIE="^DGCR(399,"
- SET (DA,Y)=+IBIFN
- SET DR="110///"_IBADD1
- DO ^DIE
- KILL DIE,DR,DA
- +1 ;I $D(^DPT(DFN,.11)) S IBST=$P(^(.11),U,5),IBST=$S(IBST'="":$P(^DIC(5,IBST,0),U,2),1:"")
- +2 SET IBBNO=$PIECE(IB(0),"^")
- SET IBDT=$PIECE(IB(0),"^",3)
- +3 DO 2^VADPT
- +4 ;I $P(IB(0),U,5)<3 S Y=0 F I=1:1 S Y=$O(^DGPM("APTT1",DFN,Y)) Q:'Y S:$E(Y,1,7)=IBDT IBDA=Y
- +5 QUIT
- 1 ;Demographic variables set
- +1 DO Q1^IBCVA
- EN1 IF '$DATA(DFN)
- QUIT
- SET IBMAR=$SELECT($PIECE(IBDPT,U,5)'="":$PIECE(IBDPT,U,5),1:"U")
- IF IBMAR'="U"
- SET IBMAR=$SELECT(IBMAR=6:"S",IBMAR=2:"M",IBMAR=1:"D",IBMAR=4:"W",IBMAR=5:"X",1:"U")
- +1 IF $DATA(^DPT(DFN,.121))
- SET IBTADD=^DPT(DFN,.121)
- SET IBTST=$PIECE(IBTADD,U,5)
- SET IBTST=$SELECT(IBTST'="":$PIECE(^DIC(5,IBTST,0),U,2),1:"")
- IF $PIECE(IBTADD,U)=""
- SET IBT1="NO TEMPORARY ADDRESS"
- +2 QUIT
- 2 ;Employment variables set
- +1 DO Q1^IBCVA
- DO Q2^IBCVA
- EN2 IF '$DATA(^DPT(DFN,.311))
- SET IBEMPD=""
- IF $DATA(^DPT(DFN,.311))
- IF ^DPT(DFN,.311)'=""
- SET IBEMPD=$PIECE(^(.311),U)_"^"_$PIECE(^(.311),U,6)_"^"_$SELECT($PIECE(^(.311),U,7)'="":$PIECE(^(.311),U,7),1:"")_"^"_$PIECE($GET(^DPT(DFN,.22)),U,5)_"^"_$PIECE(IB(0),U,9)_"^"_$PIECE(IB(0),U,8)
- +1 IF $DATA(IBEMPD)
- IF IBEMPD'=""
- SET IBEC=$PIECE(^DPT(DFN,.311),"^",15)
- +2 IF $DATA(^DPT(DFN,.25))
- IF $PIECE(^DPT(DFN,.25),U,6)'=""
- SET IBSEST=$PIECE(^(.25),U,6)
- SET IBSEST=$PIECE(^DIC(5,IBSEST,0),U,2)
- +3 QUIT
- 3 ;Insurance variables set
- EN3 DO 123^IBCVA
- EN31 ; -IBdd(i) = value of ins node in dpt
- +1 IF '$DATA(^DGCR(399,IBIFN,"AIC"))
- SET IBINDT=$SELECT(+$GET(IB("U")):+IB("U"),+$GET(^DGCR(399,IBIFN,"U")):+$GET(^("U")),1:DT)
- DO ALL^IBCNS1(DFN,"IBDD",1,IBINDT)
- SET I=""
- FOR
- SET I=$ORDER(IBDD(I))
- IF 'I
- QUIT
- DO INS
- +2 IF $DATA(^DGCR(399,IBIFN,"AIC"))
- SET IBIN="I"
- FOR I=1:1:3
- SET IBIN=$ORDER(^DGCR(399,IBIFN,IBIN))
- IF IBIN'?1"I".N
- QUIT
- SET IBDD(I,0)=^DGCR(399,IBIFN,IBIN)
- DO INS
- +3 QUIT
- INS IF '$DATA(^DGCR(399,IBIFN,"AIC"))
- SET IBISEX(I)=$PIECE(IBDD(I,0),U,6)
- IF IBISEX(I)="v"
- SET IBISEX(I)=$PIECE(^DPT(DFN,0),U,2)
- SET IBISEX(I)=$SELECT(IBISEX(I)="M":"MALE",1:"FEMALE")
- +1 IF $DATA(^DGCR(399,IBIFN,"AIC"))
- SET IBISEX(I)=$PIECE(IBDD(I,0),U,6)
- IF IBISEX(I)="v"
- SET IBISEX(I)=$PIECE(^DPT(DFN,0),U,2)
- SET IBISEX(I)=$SELECT(IBISEX(I)="M":"MALE",1:"FEMALE")
- +2 IF IBISEX(I)="s"
- SET IBISEX(I)=$SELECT($PIECE(VADM(5),U,2)="MALE":"FEMALE",$PIECE(VADM(5),U,2)="FEMALE":"MALE",1:"UNSPECIFIED")
- +3 IF IBISEX(I)="o"
- SET IBISEX(I)="UNSPECIFIED"
- +4 SET IBIRN(I)=$PIECE(IBDD(I,0),U,16)
- SET IBIR(I)=$SELECT(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")
- +5 IF IBIR(I)="UNKNOWN"
- SET IBIR(I)=$SELECT('$DATA(IBDD(I,0)):"UNKNOWN",$PIECE(IBDD(I,0),U,6)="v":"PATIENT",$PIECE(IBDD(I,0),U,6)="s":"SPOUSE",1:"UNKNOWN")
- +6 ;S IBIUTL(I)=IBDD(I,0)_"^"_IBISEX(I)_"^"_IBIRN(I)
- +7 QUIT
- ADDR ;SET ADDRESS
- +1 SET IBADD1=""
- IF $DATA(^DGCR(399,IBIFN,"M"))
- IF $PIECE(^("M"),"^",10)]""
- QUIT
- +2 SET X=$SELECT($DATA(^DPT(DFN,.11)):^(.11),1:"")
- FOR I=1:1:4
- IF $PIECE(X,"^",I)]""
- SET IBADD1=IBADD1_$PIECE(X,"^",I)_","
- +3 IF $DATA(^DIC(5,+$PIECE(X,"^",5),0))
- SET IBADD1=IBADD1_$PIECE(^(0),"^",2)
- SET IBST=$PIECE(^(0),"^",2)
- +4 IF $PIECE(X,"^",12)]""
- SET IBADD1=IBADD1_" "_$PIECE(X,"^",12)
- QUIT
- +5 ;IBCVA0
