IBCNSMR7 ;ALB/TJK - MRA EXTRACT ;2/20/01 9:55 AM ;2/14/01 10:25 AM
;;2.0;INTEGRATED BILLING;**146**;21-MAR-94
;Compiles MRA Extract data
DQ ; -- entry point from task manager
N IBINSCO,DFN,DATACNT,SSN,PATNM,DOB,DIQ,DA,DIC,DR,ININSCON,INS,IBTR
N IBINSCON,Y2 K ^TMP("IBCNSMR7",$J)
;Loop through list of insurance companies involved
S IBINSCO=0
F S IBINSCO=$O(^IBE(350.9,1,99,"B",IBINSCO)) Q:'IBINSCO D
.S DIC=36,DA=IBINSCO,DR=.01,DIQ="INS(" D EN^DIQ1
.S IBINSCON=INS(36,IBINSCO,.01) K INS
.;Get subscribers for insurance company
.S DFN=0 F S DFN=$O(^DPT("AB",IBINSCO,DFN)) Q:'DFN D
..; Gather patient infor
..D ^VADPT S PATNM=VADM(1),SSN=+VADM(2),DOB=$P(VADM(3),"^")
..K VADM
..N IBN,IBX,IBCNT,IBFLG,Y,Y1,CHG,TCHG,ARBILL,EVDATE,PAREVENT,NEV
..N IBCHDT
..S NEV="" F S NEV=$O(^IB("AFDT",DFN,NEV)) Q:'NEV I -NEV'>IBAEND S PAREVENT=0 F S PAREVENT=$O(^IB("AFDT",DFN,NEV,PAREVENT)) Q:'PAREVENT D
...S (TCHG,IBN,IBFLG,IBCNT,ARBILL)=0,EVDATE=-NEV
...S IBN=0 F S IBN=$O(^IB("AF",PAREVENT,IBN)) Q:'IBN D
....Q:'$D(^IB(IBN,0)) S IBX=^(0)
....Q:$P(IBX,"^",8)["ADMISSION"
....Q:$P(IBX,"^",10)
....Q:$P(IBX,"^",11)=""
....Q:$P(IBX,"^",17)<IBABEG
....N DIC,Y
....S DIC=430,X=$P(IBX,"^",11),DIC(0)="MZ" D ^DIC Q:'Y
....I ($P(Y(0),U,8)=39)!($P(Y(0),U,8)=26) Q
....S ARBILL=+Y
....Q:$D(^TMP("IBCNSMR7",$J,"BILL",ARBILL))
....S (Y,Y2)=0
....;check for valid insurance
....F S Y=$O(^DPT(DFN,.312,"B",IBINSCO,Y)) Q:'Y S Y1=$G(^DPT(DFN,.312,Y,0)),Y2=$$CHK^IBCNS1(Y1,EVDATE,2) Q:Y2
....Q:'Y2
....D TRANS
....Q
...Q
..Q
.Q
;calls IBCSNMR8 to make .dat file and send completion message to user
K ^TMP("IBCNSMR7",$J,"BILL") D ^IBCNSMR8
END K ^TMP("IBCNSMR7",$J)
Q
TRANS ;
N T1,T0,TRAN,TDATA,TTYPE,TAMT,TCNT,IBCHDT,PAYM,DATA,EVNO,TOTP,PDATE
S (TRAN,TOTP)=0
F S TRAN=$O(^PRCA(433,"C",ARBILL,TRAN)) Q:'TRAN D
.S (IBCHDT,PDATE)=0
.S T0=$G(^PRCA(433,TRAN,0)),T1=$G(^(1))
.Q:$P(T0,"^",4)'=2
.S TTYPE=$P(T1,"^",2)
.S TAMT=$P(T1,"^",5)
.I (TTYPE=2)!(TTYPE=34) S TOTP=TOTP+TAMT,PDATE=+T1
.S EVNO=$O(^IB("AT",TRAN,0)) S:'EVNO IBX=""
.I EVNO D
..S IBX=$G(^IB(EVNO,0))
..S IBCHDT=$P(IBX,"^",17),IBX=$P(IBX,"^")
..Q
.I 'IBCHDT S IBCHDT=+T1
.;sets data in global ^TMP("IBCNSMR7",$J,"DATA")
.S DATACNT=$G(DATACNT)+1
.S DATA=SITE_TRAN_"^"_PATNM_"^"_SSN_"^"_IBINSCON_"^"_$$DTCONV(IBCHDT)
.S DATA=DATA_"^"_$J(TAMT,0,2)_"^"_$S(PDATE:$$DTCONV(PDATE),1:"")
.S DATA=DATA_"^"_$S(PDATE:$J(TAMT,0,2),1:"")_"^"_$$DTCONV(DOB)_"^"_SITE
.S DATA=DATA_"^"_$P(^PRCA(430,ARBILL,0),"^")_"^"_IBX
.S DATA=DATA_"^"_$P(^PRCA(430.3,TTYPE,0),"^")_"^"
.I '$O(^PRCA(433,"C",ARBILL,TRAN)) S DATA=DATA_$J(TOTP,0,2)
.S ^TMP("IBCNSMR7",$J,"DATA",DATACNT)=DATA
.Q
S ^TMP("IBCNSMR7",$J,"BILL",ARBILL)=""
Q
DTCONV(DATE) ;Converts dates from Fileman to Oracle format
N MON
S MON=+$E(DATE,4,5),MON=$S(MON=1:"JAN",MON=2:"FEB",MON=3:"MAR",MON=4:"APR",MON=5:"MAY",MON=6:"JUN",MON=7:"JUL",MON=8:"AUG",MON=9:"SEP",MON=10:"OCT",MON=11:"NOV",1:"DEC")
S DATE=$E(DATE,6,7)_"-"_MON_"-"_($E(DATE,1,3)+1700)
Q DATE
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSMR7 3425 printed Nov 22, 2024@17:27:47 Page 2
IBCNSMR7 ;ALB/TJK - MRA EXTRACT ;2/20/01 9:55 AM ;2/14/01 10:25 AM
+1 ;;2.0;INTEGRATED BILLING;**146**;21-MAR-94
+2 ;Compiles MRA Extract data
DQ ; -- entry point from task manager
+1 NEW IBINSCO,DFN,DATACNT,SSN,PATNM,DOB,DIQ,DA,DIC,DR,ININSCON,INS,IBTR
+2 NEW IBINSCON,Y2
KILL ^TMP("IBCNSMR7",$JOB)
+3 ;Loop through list of insurance companies involved
+4 SET IBINSCO=0
+5 FOR
SET IBINSCO=$ORDER(^IBE(350.9,1,99,"B",IBINSCO))
if 'IBINSCO
QUIT
Begin DoDot:1
+6 SET DIC=36
SET DA=IBINSCO
SET DR=.01
SET DIQ="INS("
DO EN^DIQ1
+7 SET IBINSCON=INS(36,IBINSCO,.01)
KILL INS
+8 ;Get subscribers for insurance company
+9 SET DFN=0
FOR
SET DFN=$ORDER(^DPT("AB",IBINSCO,DFN))
if 'DFN
QUIT
Begin DoDot:2
+10 ; Gather patient infor
+11 DO ^VADPT
SET PATNM=VADM(1)
SET SSN=+VADM(2)
SET DOB=$PIECE(VADM(3),"^")
+12 KILL VADM
+13 NEW IBN,IBX,IBCNT,IBFLG,Y,Y1,CHG,TCHG,ARBILL,EVDATE,PAREVENT,NEV
+14 NEW IBCHDT
+15 SET NEV=""
FOR
SET NEV=$ORDER(^IB("AFDT",DFN,NEV))
if 'NEV
QUIT
IF -NEV'>IBAEND
SET PAREVENT=0
FOR
SET PAREVENT=$ORDER(^IB("AFDT",DFN,NEV,PAREVENT))
if 'PAREVENT
QUIT
Begin DoDot:3
+16 SET (TCHG,IBN,IBFLG,IBCNT,ARBILL)=0
SET EVDATE=-NEV
+17 SET IBN=0
FOR
SET IBN=$ORDER(^IB("AF",PAREVENT,IBN))
if 'IBN
QUIT
Begin DoDot:4
+18 if '$DATA(^IB(IBN,0))
QUIT
SET IBX=^(0)
+19 if $PIECE(IBX,"^",8)["ADMISSION"
QUIT
+20 if $PIECE(IBX,"^",10)
QUIT
+21 if $PIECE(IBX,"^",11)=""
QUIT
+22 if $PIECE(IBX,"^",17)<IBABEG
QUIT
+23 NEW DIC,Y
+24 SET DIC=430
SET X=$PIECE(IBX,"^",11)
SET DIC(0)="MZ"
DO ^DIC
if 'Y
QUIT
+25 IF ($PIECE(Y(0),U,8)=39)!($PIECE(Y(0),U,8)=26)
QUIT
+26 SET ARBILL=+Y
+27 if $DATA(^TMP("IBCNSMR7",$JOB,"BILL",ARBILL))
QUIT
+28 SET (Y,Y2)=0
+29 ;check for valid insurance
+30 FOR
SET Y=$ORDER(^DPT(DFN,.312,"B",IBINSCO,Y))
if 'Y
QUIT
SET Y1=$GET(^DPT(DFN,.312,Y,0))
SET Y2=$$CHK^IBCNS1(Y1,EVDATE,2)
if Y2
QUIT
+31 if 'Y2
QUIT
+32 DO TRANS
+33 QUIT
End DoDot:4
+34 QUIT
End DoDot:3
+35 QUIT
End DoDot:2
+36 QUIT
End DoDot:1
+37 ;calls IBCSNMR8 to make .dat file and send completion message to user
+38 KILL ^TMP("IBCNSMR7",$JOB,"BILL")
DO ^IBCNSMR8
END KILL ^TMP("IBCNSMR7",$JOB)
+1 QUIT
TRANS ;
+1 NEW T1,T0,TRAN,TDATA,TTYPE,TAMT,TCNT,IBCHDT,PAYM,DATA,EVNO,TOTP,PDATE
+2 SET (TRAN,TOTP)=0
+3 FOR
SET TRAN=$ORDER(^PRCA(433,"C",ARBILL,TRAN))
if 'TRAN
QUIT
Begin DoDot:1
+4 SET (IBCHDT,PDATE)=0
+5 SET T0=$GET(^PRCA(433,TRAN,0))
SET T1=$GET(^(1))
+6 if $PIECE(T0,"^",4)'=2
QUIT
+7 SET TTYPE=$PIECE(T1,"^",2)
+8 SET TAMT=$PIECE(T1,"^",5)
+9 IF (TTYPE=2)!(TTYPE=34)
SET TOTP=TOTP+TAMT
SET PDATE=+T1
+10 SET EVNO=$ORDER(^IB("AT",TRAN,0))
if 'EVNO
SET IBX=""
+11 IF EVNO
Begin DoDot:2
+12 SET IBX=$GET(^IB(EVNO,0))
+13 SET IBCHDT=$PIECE(IBX,"^",17)
SET IBX=$PIECE(IBX,"^")
+14 QUIT
End DoDot:2
+15 IF 'IBCHDT
SET IBCHDT=+T1
+16 ;sets data in global ^TMP("IBCNSMR7",$J,"DATA")
+17 SET DATACNT=$GET(DATACNT)+1
+18 SET DATA=SITE_TRAN_"^"_PATNM_"^"_SSN_"^"_IBINSCON_"^"_$$DTCONV(IBCHDT)
+19 SET DATA=DATA_"^"_$JUSTIFY(TAMT,0,2)_"^"_$SELECT(PDATE:$$DTCONV(PDATE),1:"")
+20 SET DATA=DATA_"^"_$SELECT(PDATE:$JUSTIFY(TAMT,0,2),1:"")_"^"_$$DTCONV(DOB)_"^"_SITE
+21 SET DATA=DATA_"^"_$PIECE(^PRCA(430,ARBILL,0),"^")_"^"_IBX
+22 SET DATA=DATA_"^"_$PIECE(^PRCA(430.3,TTYPE,0),"^")_"^"
+23 IF '$ORDER(^PRCA(433,"C",ARBILL,TRAN))
SET DATA=DATA_$JUSTIFY(TOTP,0,2)
+24 SET ^TMP("IBCNSMR7",$JOB,"DATA",DATACNT)=DATA
+25 QUIT
End DoDot:1
+26 SET ^TMP("IBCNSMR7",$JOB,"BILL",ARBILL)=""
+27 QUIT
DTCONV(DATE) ;Converts dates from Fileman to Oracle format
+1 NEW MON
+2 SET MON=+$EXTRACT(DATE,4,5)
SET MON=$SELECT(MON=1:"JAN",MON=2:"FEB",MON=3:"MAR",MON=4:"APR",MON=5:"MAY",MON=6:"JUN",MON=7:"JUL",MON=8:"AUG",MON=9:"SEP",MON=10:"OCT",MON=11:"NOV",1:"DEC")
+3 SET DATE=$EXTRACT(DATE,6,7)_"-"_MON_"-"_($EXTRACT(DATE,1,3)+1700)
+4 QUIT DATE
