- IBTUTL ;ALB/AAS - CLAIMS TRACKING UTILITY ROUTINE ;21-JUN-93
- ;;2.0;INTEGRATED BILLING;**23,62,517**;21-MAR-94;Build 240
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- ADM(DGPMCA,VAINDT,RANDOM,IBVSIT) ; -- set up info for adding a current admission
- ; -- Input DGPMCA = pointer for an admission to patient movement file
- ; VAINDT = optional date for admission (default is dt)
- ; RANDOM = whether or not this is a random sample
- ; IBVSIT = Pointer to visit file (optional)
- ;
- N DA,DIC,DIE,DR,X,VAIN,VA,IBSCHED,IBSCH,HCSRIEN
- I '$G(VAINDT) K VAINDT
- I '$G(DGPMCA) S VA200="" D INP^VADPT S DGPMCA=VAIN(1)
- Q:DGPMCA=""
- S RANDOM=$S($G(RANDOM):1,1:0)
- S X=$O(^IBT(356,"ADM",DFN,DGPMCA,0)) I X S IBTRN=X G ADMQ
- S IBADMDT=$P(^DGPM(DGPMCA,0),"^")
- ;S IBETYP=+$O(^IBE(356.6,"B","INPATIENT ADMISSION",0))
- S IBETYP=+$O(^IBE(356.6,"AC",1,0))
- S (IBSCH,IBTRN)=$O(^IBT(356,"ASCH",+$$SCH^IBTRKR2(DGPMCA),0))
- D:'IBTRN ADDT
- I IBTRN<1 G ADMQ
- S DA=IBTRN,DIE="^IBT(356,"
- L +^IBT(356,+IBTRN):10 I '$T G ADMQ
- S DR=$$ADMDR(IBADMDT,IBETYP,DGPMCA,RANDOM)
- D ^DIE K DA,DR,DIE
- I $P($G(^IBT(356,IBTRN,0)),"^",32) S DA=IBTRN,DR=".32///@",DIE="^IBT(356," D ^DIE K DA,DR,DIE
- L -^IBT(356,+IBTRN)
- I "^1^5^"[(U_IBETYP_U) S HCSRIEN=+$$FNDHCSR(DFN,IBADMDT) D:HCSRIEN HCSRCPY(HCSRIEN,IBTRN,DFN,IBADMDT)
- ;
- S IBSCHED=$S($P(^DGPM(DGPMCA,0),U,25):10,1:20)
- ;
- ; -- if random sample add hospital review
- I $P(^IBT(356,IBTRN,0),U,25) D PRE^IBTUTL2(DT,IBTRN,IBSCHED)
- ;
- ; -- if scheduled admission entry converted to admission, don't add
- ; second insurance review
- I $G(IBSCH) G ADMQ
- ;
- ; -- if insured add ins review
- I $P(^IBT(356,IBTRN,0),U,24) D COM^IBTUTL3(DT,IBTRN,IBSCHED,$G(IBTRV))
- ;
- ADMQ Q
- ;
- ADDT ; -- add new entry to tracking, ibt(356
- ;
- N %DT,DD,DO,DIC,DR,DIE,DLAYGO,IBTR1,DINUM
- L +^IBT(356,0):0 ;I '$T S Y="-1^IB085" G ADDTQ
- ;I $G(^IBT(356,0))="" S Y="-1^IB086" G ADDTQ
- S X=$P($G(^IBT(356,0)),"^",3)+1 L -^IBT(356,0)
- S DIC="^IBT(356,",DIC(0)="L",DLAYGO=356
- F X=X:1 L:$D(IBTR1) -^IBT(356,IBTR1) I X>0,'$D(^IBT(356,X)) S IBTR1=X L +^IBT(356,IBTR1):1 I $T,'$D(^IBT(356,X)) S DINUM=X,X=($$IBSITE())_X D FILE^DICN I +Y>0 Q
- L -^IBT(356,IBTR1)
- I +Y<1 S Y="-1^IB087"
- ADDTQ ;I +Y<0 D ^IBTERR
- S IBTRN=+Y,IBNEW=1
- Q
- ;
- OTH(DFN,IBETYP,IBTDT) ; -- add miscellaneous entries, care may not be in data base
- ; -- input dfn := patient pointer to 2
- ; ibetyp := pointer to type entry in 356.6
- ; ibtdt := episode date
- ;
- N X,Y,DA,DR,DIE,DIC
- S X=$O(^IBT(356,"APTY",DFN,IBETYP,IBTDT,0)) I X S IBTRN=X G OTHQ
- D ADDT
- I IBTRN<1 G OTHQ
- S DA=IBTRN,DIE="^IBT(356,"
- S DR=".02////"_$G(DFN)_";.06////"_+$G(IBTDT)_";.18////"_IBETYP_";.2////1;.24////"_$$INSURED^IBCNS1(DFN)_";1.01///NOW;1.02////"_DUZ_";.17////"_$$EABD(IBETYP,IBTDT)
- L +^IBT(356,+IBTRN):10 I '$T G OTHQ
- D ^DIE K DA,DR,DIE
- L -^IBT(356,+IBTRN)
- OTHQ Q
- ;
- IBSITE() ; -- calculate site from site parameters
- ; -- output ibsite = station number
- ;
- N IBFAC,IBSITE
- D SITE^IBAUTL
- Q IBSITE
- ;
- ADMDR(IBADMDT,IBETYP,DGPMCA,RANDOM) ; -- set up dr string for admissions
- S DR=""
- I '$G(IBETYP)!'$G(IBADMDT) G ADMDRQ
- S DR=".02////"_$G(DFN)_";.03////"_$G(IBVSIT)_";.05////"_$G(DGPMCA)_";.06////"_+$G(IBADMDT)_";.18////"_$G(IBETYP)_";.2////1;.24////"_$$INSURED^IBCNS1(DFN)_";1.01///NOW;1.02////"_DUZ_";.17////"_$$EABD(IBETYP,$G(IBADMDT)) D
- .I $G(DGPMCA),$G(RANDOM) S DR=DR_";.25////1" Q
- ADMDRQ Q DR
- ;
- EABD(IBETYP,IBTDT) ; -- compute earliest auto bill date: date entered plus days delay for event type
- ; -- input IBETYPE = pointer to type of entry file
- ; IBTDT = episode date, if not passed in uses DT
- ;
- N X,X1,X2,Y,IBETYPD S Y="" I '$G(IBETYP) G EABDQ
- S IBETYPD=$G(^IBE(356.6,+IBETYP,0)) I '$G(IBTDT) S IBTDT=DT
- I '$P(IBETYPD,"^",4) G EABDQ ; automated billing turned off
- S X2=+$P(IBETYPD,"^",6) ;set earliest autobill date to entered date plus days delay
- S X1=IBTDT D C^%DTC S Y=X\1
- EABDQ Q Y
- ;
- BILL(IBTRN) ;check if event is billable, return EABD if it is
- N X,Y,Z,IBTRND S (X,Y)="" S IBTRND=$G(^IBT(356,+$G(IBTRN),0)) I IBTRND="" G BILLQ
- ;
- ; -- billed and bill not cancelled and not inpt interim first or continuous
- I +$P(IBTRND,U,11) S Z=$$BILLED^IBCU8(IBTRN),Y=$P(Z,U,2) I +Z,'Y G BILLQ
- ;
- ; -- special type (not riem. ins), not billable, inactive
- I +$P(IBTRND,U,12)!(+$P(IBTRND,U,19))!('$P(IBTRND,U,20)) G BILLQ
- I 'Y S Y=+$G(^IBT(356,+$G(IBTRN),1)) I 'Y S Y=DT
- S X=$$EABD(+$P(IBTRND,U,18),Y)
- BILLQ Q X
- ;
- STOBIL Q
- KTOBIL Q
- ;
- FNDHCSR(DFN,IBADMDT) ; find matching HCSR response in file 356.22
- ; DFN - file 2 ien
- ; IBADMDT - event date
- ;
- ; returns file 356.22 ien of matching response or null if no match found
- ;
- N EVDT,HCSRIEN,RES,STOPFLG
- S RES=""
- I +$G(DFN)>0,+$G(IBADMDT)>0 D
- .; loop through D-xref (by patient and event date)
- .S STOPFLG=0,EVDT="" F S EVDT=$O(^IBT(356.22,"D",DFN,EVDT)) Q:EVDT=""!STOPFLG D
- ..; if match found, loop through entries for that patient and event date
- ..I $P(EVDT,"-")=IBADMDT S HCSRIEN=0 F S HCSRIEN=$O(^IBT(356.22,"D",DFN,EVDT,HCSRIEN)) Q:'HCSRIEN!STOPFLG D
- ...; check if this entry is a response
- ...I $$GET1^DIQ(356.22,HCSRIEN_",",.13,"I") S RES=HCSRIEN,STOPFLG=1
- ...Q
- ..Q
- .Q
- Q RES
- ;
- HCSRCPY(HCSRIEN,IBTRN,DFN,EVNTDT) ; copy ref. # and auth. # from file 356.22 into file 356.2
- ; HCSRIEN - file 356.22 ien
- ; IBTRN - file 356 ien
- ; DFN - file 2 ien
- ; EVNTDT - event date from 356.22/.07
- ;
- N CERT,FDA,FLD,HCSRIENS,IENS,IIEN,IMIEN,IRIEN,IRIENS,NUM
- I +$G(HCSRIEN)>0,+$G(IBTRN)>0 D
- .S HCSRIENS=HCSRIEN_","
- .S CERT=$$GET1^DIQ(356.22,HCSRIENS,103.01)
- .S NUM=$$GET1^DIQ(356.22,HCSRIENS,103.02,"I")
- .S IMIEN=$$GET1^DIQ(356.22,HCSRIENS,.03) ;Insurance Multiple IEN
- .S IENS=IMIEN_","_DFN_"," ;
- .S IIEN=$$GET1^DIQ(2.312,IENS,.01,"I") ; Insurance Company IEN
- .S FLD=2.01 ; default to ref. #, goes into 356.2/2.01
- .I "^A1^A2^A6^"[(U_CERT_U) S FLD=2.02 ; it's an auth. #, goes into 356.2/2.02
- .;
- .;If there are no entries in 356.2 and it's outpatient, add an entry to 356.2
- .I '$D(^IBT(356.2,"C",IBTRN)),$P($G(^IBT(356.22,RESIEN,0)),U,4)'="I" D ADD(EVNTDT,IBTRN,DFN,NUM,FLD,IIEN) Q
- .;
- .; find appropriate entries in file 356.2
- .S IRIEN=0 F S IRIEN=$O(^IBT(356.2,"C",IBTRN,IRIEN)) Q:'IRIEN D
- ..S IRIENS=IRIEN_","
- ..Q:IIEN'=$$GET1^DIQ(356.2,IRIENS,.08,"I") ; don't set if it's not the correct insurance company
- ..S:$P($G(^IBT(356.2,IRIEN,2)),U,$S(FLD=2.02:2,1:1))="" FDA(356.2,IRIENS,FLD)=NUM
- ..D FILE^DIE(,"FDA") K FDA
- ..Q
- .Q
- Q
- ;
- ; add an entry to 365.2
- ; for outpatient if there isn't one already
- ADD(EVNTDT,IBTRN,DFN,NUM,FLD,IIEN) ; -- add initial entry
- ; EVNTDT - EVNTDT (in internal fileman format)
- ; IBTRN - file 356 ien
- ; DFN - file 2 ien
- ; NUM - authorization or referral number
- ; FLD - field to file it it.
- ; IIEN - Insurance Company IEN
- ;
- N FDA,HIP,IBDD,IBNXRV,IBTOC,ORDER,STOP
- I $G(NUM)]"",$G(FLD)]"",+$G(IIEN) D
- .;
- .D ALL^IBCNS1(DFN,"IBDD",1,EVNTDT,1) ; return active insurances in COB order
- .Q:'$G(IBDD(0)) ; no active insurance on that date
- .;
- .; get first insurance company that matches
- .S ORDER=0 F S ORDER=$O(IBDD("S",ORDER)) Q:'ORDER D Q:HIP
- ..S HIP=0 F S HIP=$O(IBDD("S",ORDER,HIP)) Q:'HIP Q:+$G(IBDD(HIP,0))=IIEN
- .Q:'$G(HIP) ; stop if none match
- .;
- .S FDA(356.2,"+1,",.01)=EVNTDT
- .;
- .;Pointer to claims tracking
- .S FDA(356.2,"+1,",.02)=IBTRN
- .S FDA(356.2,"+1,",.19)=1
- .;
- .;Type of Contact
- .S IBTOC=$$FIND1^DIC(356.11,,"C","OUTPATIENT TREATMENT")
- .S FDA(356.2,"+1,",.04)=IBTOC
- .;
- .;Patient
- .S FDA(356.2,"+1,",.05)=DFN
- .;
- .; Health Insurance Policy
- .S FDA(356.2,"+1,",1.05)=HIP
- .;
- .;File referal or authorization
- .S FDA(356.2,"+1,",FLD)=NUM
- .;
- .; Next Review
- .S IBNXRV=DT
- .I EVNTDT>$$FMADD^XLFDT(DT,7) S IBNXRV=$$FMADD^XLFDT(EVNTDT,-7)
- .S FDA(356.2,"+1,",.24)=IBNXRV
- .;
- .;Last Edit Date/By
- .D NOW^%DTC
- .S FDA(356.2,"+1,",1.01)=%
- .S FDA(356.2,"+1,",1.02)=DUZ
- .;
- .D UPDATE^DIE(,"FDA") K FDA
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTUTL 8112 printed Jan 18, 2025@03:30:24 Page 2
- IBTUTL ;ALB/AAS - CLAIMS TRACKING UTILITY ROUTINE ;21-JUN-93
- +1 ;;2.0;INTEGRATED BILLING;**23,62,517**;21-MAR-94;Build 240
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- ADM(DGPMCA,VAINDT,RANDOM,IBVSIT) ; -- set up info for adding a current admission
- +1 ; -- Input DGPMCA = pointer for an admission to patient movement file
- +2 ; VAINDT = optional date for admission (default is dt)
- +3 ; RANDOM = whether or not this is a random sample
- +4 ; IBVSIT = Pointer to visit file (optional)
- +5 ;
- +6 NEW DA,DIC,DIE,DR,X,VAIN,VA,IBSCHED,IBSCH,HCSRIEN
- +7 IF '$GET(VAINDT)
- KILL VAINDT
- +8 IF '$GET(DGPMCA)
- SET VA200=""
- DO INP^VADPT
- SET DGPMCA=VAIN(1)
- +9 if DGPMCA=""
- QUIT
- +10 SET RANDOM=$SELECT($GET(RANDOM):1,1:0)
- +11 SET X=$ORDER(^IBT(356,"ADM",DFN,DGPMCA,0))
- IF X
- SET IBTRN=X
- GOTO ADMQ
- +12 SET IBADMDT=$PIECE(^DGPM(DGPMCA,0),"^")
- +13 ;S IBETYP=+$O(^IBE(356.6,"B","INPATIENT ADMISSION",0))
- +14 SET IBETYP=+$ORDER(^IBE(356.6,"AC",1,0))
- +15 SET (IBSCH,IBTRN)=$ORDER(^IBT(356,"ASCH",+$$SCH^IBTRKR2(DGPMCA),0))
- +16 if 'IBTRN
- DO ADDT
- +17 IF IBTRN<1
- GOTO ADMQ
- +18 SET DA=IBTRN
- SET DIE="^IBT(356,"
- +19 LOCK +^IBT(356,+IBTRN):10
- IF '$TEST
- GOTO ADMQ
- +20 SET DR=$$ADMDR(IBADMDT,IBETYP,DGPMCA,RANDOM)
- +21 DO ^DIE
- KILL DA,DR,DIE
- +22 IF $PIECE($GET(^IBT(356,IBTRN,0)),"^",32)
- SET DA=IBTRN
- SET DR=".32///@"
- SET DIE="^IBT(356,"
- DO ^DIE
- KILL DA,DR,DIE
- +23 LOCK -^IBT(356,+IBTRN)
- +24 IF "^1^5^"[(U_IBETYP_U)
- SET HCSRIEN=+$$FNDHCSR(DFN,IBADMDT)
- if HCSRIEN
- DO HCSRCPY(HCSRIEN,IBTRN,DFN,IBADMDT)
- +25 ;
- +26 SET IBSCHED=$SELECT($PIECE(^DGPM(DGPMCA,0),U,25):10,1:20)
- +27 ;
- +28 ; -- if random sample add hospital review
- +29 IF $PIECE(^IBT(356,IBTRN,0),U,25)
- DO PRE^IBTUTL2(DT,IBTRN,IBSCHED)
- +30 ;
- +31 ; -- if scheduled admission entry converted to admission, don't add
- +32 ; second insurance review
- +33 IF $GET(IBSCH)
- GOTO ADMQ
- +34 ;
- +35 ; -- if insured add ins review
- +36 IF $PIECE(^IBT(356,IBTRN,0),U,24)
- DO COM^IBTUTL3(DT,IBTRN,IBSCHED,$GET(IBTRV))
- +37 ;
- ADMQ QUIT
- +1 ;
- ADDT ; -- add new entry to tracking, ibt(356
- +1 ;
- +2 NEW %DT,DD,DO,DIC,DR,DIE,DLAYGO,IBTR1,DINUM
- +3 ;I '$T S Y="-1^IB085" G ADDTQ
- LOCK +^IBT(356,0):0
- +4 ;I $G(^IBT(356,0))="" S Y="-1^IB086" G ADDTQ
- +5 SET X=$PIECE($GET(^IBT(356,0)),"^",3)+1
- LOCK -^IBT(356,0)
- +6 SET DIC="^IBT(356,"
- SET DIC(0)="L"
- SET DLAYGO=356
- +7 FOR X=X:1
- if $DATA(IBTR1)
- LOCK -^IBT(356,IBTR1)
- IF X>0
- IF '$DATA(^IBT(356,X))
- SET IBTR1=X
- LOCK +^IBT(356,IBTR1):1
- IF $TEST
- IF '$DATA(^IBT(356,X))
- SET DINUM=X
- SET X=($$IBSITE())_X
- DO FILE^DICN
- IF +Y>0
- QUIT
- +8 LOCK -^IBT(356,IBTR1)
- +9 IF +Y<1
- SET Y="-1^IB087"
- ADDTQ ;I +Y<0 D ^IBTERR
- +1 SET IBTRN=+Y
- SET IBNEW=1
- +2 QUIT
- +3 ;
- OTH(DFN,IBETYP,IBTDT) ; -- add miscellaneous entries, care may not be in data base
- +1 ; -- input dfn := patient pointer to 2
- +2 ; ibetyp := pointer to type entry in 356.6
- +3 ; ibtdt := episode date
- +4 ;
- +5 NEW X,Y,DA,DR,DIE,DIC
- +6 SET X=$ORDER(^IBT(356,"APTY",DFN,IBETYP,IBTDT,0))
- IF X
- SET IBTRN=X
- GOTO OTHQ
- +7 DO ADDT
- +8 IF IBTRN<1
- GOTO OTHQ
- +9 SET DA=IBTRN
- SET DIE="^IBT(356,"
- +10 SET DR=".02////"_$GET(DFN)_";.06////"_+$GET(IBTDT)_";.18////"_IBETYP_";.2////1;.24////"_$$INSURED^IBCNS1(DFN)_";1.01///NOW;1.02////"_DUZ_";.17////"_$$EABD(IBETYP,IBTDT)
- +11 LOCK +^IBT(356,+IBTRN):10
- IF '$TEST
- GOTO OTHQ
- +12 DO ^DIE
- KILL DA,DR,DIE
- +13 LOCK -^IBT(356,+IBTRN)
- OTHQ QUIT
- +1 ;
- IBSITE() ; -- calculate site from site parameters
- +1 ; -- output ibsite = station number
- +2 ;
- +3 NEW IBFAC,IBSITE
- +4 DO SITE^IBAUTL
- +5 QUIT IBSITE
- +6 ;
- ADMDR(IBADMDT,IBETYP,DGPMCA,RANDOM) ; -- set up dr string for admissions
- +1 SET DR=""
- +2 IF '$GET(IBETYP)!'$GET(IBADMDT)
- GOTO ADMDRQ
- +3 SET DR=".02////"_$GET(DFN)_";.03////"_$GET(IBVSIT)_";.05////"_$GET(DGPMCA)_";.06////"_+$GET(IBADMDT)_";.18////"_$GET(IBETYP)_";.2////1;.24////"_$$INSURED^IBCNS1(DFN)_";1.01///NOW;1.02////"_DUZ_";.17////"_$$EABD(IBETYP,$GET(IBADMDT))
- Begin DoDot:1
- +4 IF $GET(DGPMCA)
- IF $GET(RANDOM)
- SET DR=DR_";.25////1"
- QUIT
- End DoDot:1
- ADMDRQ QUIT DR
- +1 ;
- EABD(IBETYP,IBTDT) ; -- compute earliest auto bill date: date entered plus days delay for event type
- +1 ; -- input IBETYPE = pointer to type of entry file
- +2 ; IBTDT = episode date, if not passed in uses DT
- +3 ;
- +4 NEW X,X1,X2,Y,IBETYPD
- SET Y=""
- IF '$GET(IBETYP)
- GOTO EABDQ
- +5 SET IBETYPD=$GET(^IBE(356.6,+IBETYP,0))
- IF '$GET(IBTDT)
- SET IBTDT=DT
- +6 ; automated billing turned off
- IF '$PIECE(IBETYPD,"^",4)
- GOTO EABDQ
- +7 ;set earliest autobill date to entered date plus days delay
- SET X2=+$PIECE(IBETYPD,"^",6)
- +8 SET X1=IBTDT
- DO C^%DTC
- SET Y=X\1
- EABDQ QUIT Y
- +1 ;
- BILL(IBTRN) ;check if event is billable, return EABD if it is
- +1 NEW X,Y,Z,IBTRND
- SET (X,Y)=""
- SET IBTRND=$GET(^IBT(356,+$GET(IBTRN),0))
- IF IBTRND=""
- GOTO BILLQ
- +2 ;
- +3 ; -- billed and bill not cancelled and not inpt interim first or continuous
- +4 IF +$PIECE(IBTRND,U,11)
- SET Z=$$BILLED^IBCU8(IBTRN)
- SET Y=$PIECE(Z,U,2)
- IF +Z
- IF 'Y
- GOTO BILLQ
- +5 ;
- +6 ; -- special type (not riem. ins), not billable, inactive
- +7 IF +$PIECE(IBTRND,U,12)!(+$PIECE(IBTRND,U,19))!('$PIECE(IBTRND,U,20))
- GOTO BILLQ
- +8 IF 'Y
- SET Y=+$GET(^IBT(356,+$GET(IBTRN),1))
- IF 'Y
- SET Y=DT
- +9 SET X=$$EABD(+$PIECE(IBTRND,U,18),Y)
- BILLQ QUIT X
- +1 ;
- STOBIL QUIT
- KTOBIL QUIT
- +1 ;
- FNDHCSR(DFN,IBADMDT) ; find matching HCSR response in file 356.22
- +1 ; DFN - file 2 ien
- +2 ; IBADMDT - event date
- +3 ;
- +4 ; returns file 356.22 ien of matching response or null if no match found
- +5 ;
- +6 NEW EVDT,HCSRIEN,RES,STOPFLG
- +7 SET RES=""
- +8 IF +$GET(DFN)>0
- IF +$GET(IBADMDT)>0
- Begin DoDot:1
- +9 ; loop through D-xref (by patient and event date)
- +10 SET STOPFLG=0
- SET EVDT=""
- FOR
- SET EVDT=$ORDER(^IBT(356.22,"D",DFN,EVDT))
- if EVDT=""!STOPFLG
- QUIT
- Begin DoDot:2
- +11 ; if match found, loop through entries for that patient and event date
- +12 IF $PIECE(EVDT,"-")=IBADMDT
- SET HCSRIEN=0
- FOR
- SET HCSRIEN=$ORDER(^IBT(356.22,"D",DFN,EVDT,HCSRIEN))
- if 'HCSRIEN!STOPFLG
- QUIT
- Begin DoDot:3
- +13 ; check if this entry is a response
- +14 IF $$GET1^DIQ(356.22,HCSRIEN_",",.13,"I")
- SET RES=HCSRIEN
- SET STOPFLG=1
- +15 QUIT
- End DoDot:3
- +16 QUIT
- End DoDot:2
- +17 QUIT
- End DoDot:1
- +18 QUIT RES
- +19 ;
- HCSRCPY(HCSRIEN,IBTRN,DFN,EVNTDT) ; copy ref. # and auth. # from file 356.22 into file 356.2
- +1 ; HCSRIEN - file 356.22 ien
- +2 ; IBTRN - file 356 ien
- +3 ; DFN - file 2 ien
- +4 ; EVNTDT - event date from 356.22/.07
- +5 ;
- +6 NEW CERT,FDA,FLD,HCSRIENS,IENS,IIEN,IMIEN,IRIEN,IRIENS,NUM
- +7 IF +$GET(HCSRIEN)>0
- IF +$GET(IBTRN)>0
- Begin DoDot:1
- +8 SET HCSRIENS=HCSRIEN_","
- +9 SET CERT=$$GET1^DIQ(356.22,HCSRIENS,103.01)
- +10 SET NUM=$$GET1^DIQ(356.22,HCSRIENS,103.02,"I")
- +11 ;Insurance Multiple IEN
- SET IMIEN=$$GET1^DIQ(356.22,HCSRIENS,.03)
- +12 ;
- SET IENS=IMIEN_","_DFN_","
- +13 ; Insurance Company IEN
- SET IIEN=$$GET1^DIQ(2.312,IENS,.01,"I")
- +14 ; default to ref. #, goes into 356.2/2.01
- SET FLD=2.01
- +15 ; it's an auth. #, goes into 356.2/2.02
- IF "^A1^A2^A6^"[(U_CERT_U)
- SET FLD=2.02
- +16 ;
- +17 ;If there are no entries in 356.2 and it's outpatient, add an entry to 356.2
- +18 IF '$DATA(^IBT(356.2,"C",IBTRN))
- IF $PIECE($GET(^IBT(356.22,RESIEN,0)),U,4)'="I"
- DO ADD(EVNTDT,IBTRN,DFN,NUM,FLD,IIEN)
- QUIT
- +19 ;
- +20 ; find appropriate entries in file 356.2
- +21 SET IRIEN=0
- FOR
- SET IRIEN=$ORDER(^IBT(356.2,"C",IBTRN,IRIEN))
- if 'IRIEN
- QUIT
- Begin DoDot:2
- +22 SET IRIENS=IRIEN_","
- +23 ; don't set if it's not the correct insurance company
- if IIEN'=$$GET1^DIQ(356.2,IRIENS,.08,"I")
- QUIT
- +24 if $PIECE($GET(^IBT(356.2,IRIEN,2)),U,$SELECT(FLD=2.02
- SET FDA(356.2,IRIENS,FLD)=NUM
- +25 DO FILE^DIE(,"FDA")
- KILL FDA
- +26 QUIT
- End DoDot:2
- +27 QUIT
- End DoDot:1
- +28 QUIT
- +29 ;
- +30 ; add an entry to 365.2
- +31 ; for outpatient if there isn't one already
- ADD(EVNTDT,IBTRN,DFN,NUM,FLD,IIEN) ; -- add initial entry
- +1 ; EVNTDT - EVNTDT (in internal fileman format)
- +2 ; IBTRN - file 356 ien
- +3 ; DFN - file 2 ien
- +4 ; NUM - authorization or referral number
- +5 ; FLD - field to file it it.
- +6 ; IIEN - Insurance Company IEN
- +7 ;
- +8 NEW FDA,HIP,IBDD,IBNXRV,IBTOC,ORDER,STOP
- +9 IF $GET(NUM)]""
- IF $GET(FLD)]""
- IF +$GET(IIEN)
- Begin DoDot:1
- +10 ;
- +11 ; return active insurances in COB order
- DO ALL^IBCNS1(DFN,"IBDD",1,EVNTDT,1)
- +12 ; no active insurance on that date
- if '$GET(IBDD(0))
- QUIT
- +13 ;
- +14 ; get first insurance company that matches
- +15 SET ORDER=0
- FOR
- SET ORDER=$ORDER(IBDD("S",ORDER))
- if 'ORDER
- QUIT
- Begin DoDot:2
- +16 SET HIP=0
- FOR
- SET HIP=$ORDER(IBDD("S",ORDER,HIP))
- if 'HIP
- QUIT
- if +$GET(IBDD(HIP,0))=IIEN
- QUIT
- End DoDot:2
- if HIP
- QUIT
- +17 ; stop if none match
- if '$GET(HIP)
- QUIT
- +18 ;
- +19 SET FDA(356.2,"+1,",.01)=EVNTDT
- +20 ;
- +21 ;Pointer to claims tracking
- +22 SET FDA(356.2,"+1,",.02)=IBTRN
- +23 SET FDA(356.2,"+1,",.19)=1
- +24 ;
- +25 ;Type of Contact
- +26 SET IBTOC=$$FIND1^DIC(356.11,,"C","OUTPATIENT TREATMENT")
- +27 SET FDA(356.2,"+1,",.04)=IBTOC
- +28 ;
- +29 ;Patient
- +30 SET FDA(356.2,"+1,",.05)=DFN
- +31 ;
- +32 ; Health Insurance Policy
- +33 SET FDA(356.2,"+1,",1.05)=HIP
- +34 ;
- +35 ;File referal or authorization
- +36 SET FDA(356.2,"+1,",FLD)=NUM
- +37 ;
- +38 ; Next Review
- +39 SET IBNXRV=DT
- +40 IF EVNTDT>$$FMADD^XLFDT(DT,7)
- SET IBNXRV=$$FMADD^XLFDT(EVNTDT,-7)
- +41 SET FDA(356.2,"+1,",.24)=IBNXRV
- +42 ;
- +43 ;Last Edit Date/By
- +44 DO NOW^%DTC
- +45 SET FDA(356.2,"+1,",1.01)=%
- +46 SET FDA(356.2,"+1,",1.02)=DUZ
- +47 ;
- +48 DO UPDATE^DIE(,"FDA")
- KILL FDA
- End DoDot:1
- +49 QUIT