IBNCPLOG ;BHAM ISC/SS - IB ECME EVNT REPORT ;3/5/08 14:02
;;2.0;INTEGRATED BILLING;**342,339,363,383,411,435,452,534,550,647**;21-MAR-94;Build 10
;;Per VA Directive 6402, this routine should not be modified.
;
;store data related to the IB calls made by ECME package in the file #366.14
;input:
;.IBIBD - (by reference) IBD array with parameter sent to IB by ECME
;DFN patient's ien
;IBPROC - type of event. i.e. content of CALL such as BILL, REJECT and so on
;IBRESULT - (optional) result of the event processing, format: return_code^message
;IBJOB - (optional) job, default = $J
;IBDTTM - (optional) datetime, default = "NOW"
;IBUSR - (optional) user ID, default = DUZ
;output:
;none
LOG(IBIBD,DFN,IBPROC,IBRESULT,IBJOB,IBDTTM,IBUSR) ;Store the data
N NDX,Z,REF,IBDATE,IBDTIEN,IBEVNIEN,IBIBDTYP,IBRETV,IBPTR
S IBRESULT=$G(IBRESULT)
;
I '$G(IBJOB) S IBJOB=$J
I '$G(IBDTTM) S IBDTTM=$$NOW^XLFDT()
I '$G(IBUSR) S IBUSR=+DUZ
;
S IBDATE=DT
S IBDTIEN=+$O(^IBCNR(366.14,"B",IBDATE,0))
L +^IBCNR(366.14):30 E Q
I IBDTIEN=0 S IBDTIEN=+$$ADDDATE(IBDATE)
;create an event
S IBEVNIEN=$$NEWEVENT(IBDTIEN,IBPROC)
L -^IBCNR(366.14)
I IBEVNIEN=0 W !,"New event creation Error : LOG^IBNCPLOG",! Q
;
I +$$FILLFLDS^IBNCPUT1(366.141,".03",IBEVNIEN_","_IBDTIEN,DFN) ;DFN
I +$$FILLFLDS^IBNCPUT1(366.141,".04",IBEVNIEN_","_IBDTIEN,IBJOB) ;JOB
I +$$FILLFLDS^IBNCPUT1(366.141,".05",IBEVNIEN_","_IBDTIEN,IBDTTM) ;DATETIME
I +$$FILLFLDS^IBNCPUT1(366.141,".06",IBEVNIEN_","_IBDTIEN,DUZ) ;USER
I IBRESULT'="" D
. S IBRETV=+$$FILLFLDS^IBNCPUT1(366.141,".07",IBEVNIEN_","_IBDTIEN,+IBRESULT) ;RESULT
. S IBRETV=+$$FILLFLDS^IBNCPUT1(366.141,".08",IBEVNIEN_","_IBDTIEN,$P(IBRESULT,U,2)) ;RESULT MESSAGE
. I IBPROC="BILLABLE STATUS CHECK",$P(IBRESULT,U,2)]"" D
.. S IBPTR=$$GETREAS($P(IBRESULT,U,2))
.. I IBPTR S IBRETV=+$$FILLFLDS^IBNCPUT1(366.141,".02",IBEVNIEN_","_IBDTIEN,IBPTR) ; Non-Billable Status Reason
. I $P(IBRESULT,U,3)'="" S IBRETV=+$$FILLFLDS^IBNCPUT1(366.141,"7.05",IBEVNIEN_","_IBDTIEN,$P(IBRESULT,U,3)) ; Eligibility from IB billing determination (IB*2*452)
. Q
;
;store IBIBD array
S IBIBDTYP=""
F S IBIBDTYP=$O(IBIBD(IBIBDTYP)) Q:IBIBDTYP="" D
. D IBD(IBDTIEN,IBEVNIEN,IBIBDTYP,$G(IBIBD(IBIBDTYP)),.IBIBD)
;store "INS" node of IBIBD array
I $D(IBIBD("INS")) I $$INS(.IBIBD,IBDTIEN,IBEVNIEN)
Q
;
;store IBD array data
;IBDTIEN - ien on top [DATE] level
;IBRECNO - ien in [EVENTS] multiple
;IBIBDTYP - type subscript in IBD array (BILL, PAID, RESPONSE, etc)
;IBVAL - value to store
;IBIBD - array with data passed by reference (for efficiency)
IBD(IBDTIEN,IBRECNO,IBIBDTYP,IBVAL,IBIBD) ;
N IBFLDNO
;W !," - ",IBRECNO," ",IBIBDTYP," = ",IBVAL
;free text like "WEBMD: PAID"
I IBIBDTYP="AUTH #" S IBFLDNO=".11",IBVAL=$E(IBVAL,1,30) G EDITIBD
;free text like "0504597;3051229"
I IBIBDTYP="BCID" S IBFLDNO=".12" G EDITIBD
;7 or 12 digit ECME number - identifier (stored as a text - might have leading zeroes)
I IBIBDTYP="CLAIMID" S IBFLDNO=".13" G EDITIBD
;pointer to file #2
I IBIBDTYP="DFN" S IBFLDNO=".14" G EDITIBD
;pointer to file #40.8
I IBIBDTYP="DIVISION" S IBFLDNO=".15" G EDITIBD
;free text
I IBIBDTYP="RESPONSE" S IBFLDNO=".16",IBVAL=$E(IBVAL,1,20) G EDITIBD
;free text
I IBIBDTYP="REVERSAL REASON" S IBFLDNO=".17",IBVAL=$E(IBVAL,1,40) G EDITIBD
;1 digit number
I IBIBDTYP="RTS-DEL" S IBFLDNO=".18" G EDITIBD
;free text
I IBIBDTYP="STATUS" S IBFLDNO=".19",IBVAL=$E(IBVAL,1,20) G EDITIBD
;Prescription number as a text, might have alpha characters (external value, this is not IEN)
I IBIBDTYP="RX NO" S IBFLDNO=".202",IBVAL=$E(IBVAL,1,20) G EDITIBD
;0 - original, 1,2,3,... - refill number
I IBIBDTYP="FILL NUMBER" S IBFLDNO=".203" G EDITIBD
;internal identifier number for a DRUG
I IBIBDTYP="DRUG" S IBFLDNO=".204" G EDITIBD
I IBIBDTYP="NDC" S IBFLDNO=".205" G EDITIBD
I IBIBDTYP="DOS" S IBFLDNO=".206" G EDITIBD
I IBIBDTYP="RELEASE DATE" S IBFLDNO=".207" G EDITIBD
I IBIBDTYP="QTY" S IBFLDNO=".208" G EDITIBD
I IBIBDTYP="UNITS" S IBFLDNO=".213" G EDITIBD
I IBIBDTYP="NCPDP QTY" S IBFLDNO=".214" G EDITIBD
I IBIBDTYP="NCPDP UNITS" S IBFLDNO=".215" G EDITIBD
I IBIBDTYP="DAYS SUPPLY" S IBFLDNO=".209" G EDITIBD
I IBIBDTYP="DEA" S IBFLDNO=".21" G EDITIBD
I IBIBDTYP="FILLED BY" S IBFLDNO=".211" G EDITIBD
I IBIBDTYP="COPAY" S IBFLDNO=".311" G EDITIBD
I IBIBDTYP="ING COST PAID" S IBFLDNO=".312" G EDITIBD
I IBIBDTYP="DISP FEE PAID" S IBFLDNO=".313" G EDITIBD
I IBIBDTYP="PAT RESP" S IBFLDNO=".314" G EDITIBD
; for environmental indicators:
; if IBIBD("SC/EI OVR")=1 - the user overrides any answers (3)
; if $G(IBIBD("SC/EI NO ANSW")) contains the IBIBDTYP - this question was not answered (2)
; otherwise - use whatever in the IBVAL (0 - NO, 1 -YES)
I IBIBDTYP="AO" S IBFLDNO=".401",IBVAL=$S($G(IBIBD("SC/EI OVR"))=1:3,(","_$G(IBIBD("SC/EI NO ANSW"))_",")[(","_IBIBDTYP_","):2,1:IBVAL) G EDITIBD
I IBIBDTYP="CV" S IBFLDNO=".402",IBVAL=$S($G(IBIBD("SC/EI OVR"))=1:3,(","_$G(IBIBD("SC/EI NO ANSW"))_",")[(","_IBIBDTYP_","):2,1:IBVAL) G EDITIBD
I IBIBDTYP="SWA" S IBFLDNO=".403",IBVAL=$S($G(IBIBD("SC/EI OVR"))=1:3,(","_$G(IBIBD("SC/EI NO ANSW"))_",")[(","_IBIBDTYP_","):2,1:IBVAL) G EDITIBD
I IBIBDTYP="IR" S IBFLDNO=".404",IBVAL=$S($G(IBIBD("SC/EI OVR"))=1:3,(","_$G(IBIBD("SC/EI NO ANSW"))_",")[(","_IBIBDTYP_","):2,1:IBVAL) G EDITIBD
I IBIBDTYP="MST" S IBFLDNO=".405",IBVAL=$S($G(IBIBD("SC/EI OVR"))=1:3,(","_$G(IBIBD("SC/EI NO ANSW"))_",")[(","_IBIBDTYP_","):2,1:IBVAL) G EDITIBD
I IBIBDTYP="HNC" S IBFLDNO=".406",IBVAL=$S($G(IBIBD("SC/EI OVR"))=1:3,(","_$G(IBIBD("SC/EI NO ANSW"))_",")[(","_IBIBDTYP_","):2,1:IBVAL) G EDITIBD
I IBIBDTYP="SC" S IBFLDNO=".407",IBVAL=$S($G(IBIBD("SC/EI OVR"))=1:3,(","_$G(IBIBD("SC/EI NO ANSW"))_",")[(","_IBIBDTYP_","):2,1:IBVAL) G EDITIBD
I IBIBDTYP="SHAD" S IBFLDNO=".408",IBVAL=$S($G(IBIBD("SC/EI OVR"))=1:3,(","_$G(IBIBD("SC/EI NO ANSW"))_",")[(","_IBIBDTYP_","):2,1:IBVAL) G EDITIBD
I IBIBDTYP="ACT DTY OVR" S IBFLDNO=".409" G EDITIBD
I IBIBDTYP="BILL" S IBFLDNO=".301" G EDITIBD
I IBIBDTYP="BILLED" S IBFLDNO=".302" G EDITIBD
I IBIBDTYP="PLAN" S IBFLDNO=".303" G EDITIBD
I IBIBDTYP="COST" S IBFLDNO=".304" G EDITIBD
I IBIBDTYP="PAID" S IBFLDNO=".305" G EDITIBD
I IBIBDTYP="CLOSE COMMENT" S IBFLDNO=".306" G EDITIBD
I IBIBDTYP="REOPEN COMMENT" S IBFLDNO=".306" G EDITIBD
I IBIBDTYP="CLOSE REASON" S IBFLDNO=".307" G EDITIBD
I IBIBDTYP="DROP TO PAPER" S IBFLDNO=".308" G EDITIBD
I IBIBDTYP="RELEASE COPAY" S IBFLDNO=".309" G EDITIBD
I IBIBDTYP="USER" S IBFLDNO=".31" G EDITIBD
I IBIBDTYP="PRESCRIPTION" S IBFLDNO=".201" G EDITIBD
I IBIBDTYP="IEN" S IBFLDNO=".212" G EDITIBD
I IBIBDTYP="EPHARM" S IBFLDNO=".09" G EDITIBD
I IBIBDTYP="RXCOB" S IBFLDNO="7.01" G EDITIBD
I IBIBDTYP="PRIMARY BILL" S IBFLDNO="7.02" G EDITIBD
I IBIBDTYP="PRIOR PAYMENT" S IBFLDNO="7.03" G EDITIBD
I IBIBDTYP="RTYPE" S IBFLDNO="7.04" G EDITIBD
I IBIBDTYP="DRUG-BILLABLE" S IBFLDNO=7.06 G EDITIBD
I IBIBDTYP="DRUG-BILLABLE TRICARE" S IBFLDNO=7.07 G EDITIBD
I IBIBDTYP="DRUG-BILLABLE CHAMPVA" S IBFLDNO=7.08 G EDITIBD
I IBIBDTYP="DRUG-SENSITIVE DX" S IBFLDNO=7.09 G EDITIBD
Q 0
EDITIBD ;
Q +$$FILLFLDS^IBNCPUT1(366.141,IBFLDNO,IBRECNO_","_IBDTIEN,IBVAL)
;------
;to store IBD("INS") array data
;input:
;IBDARR - IBD array by reference
;IBDTIEN - ien on top [DATE] level
;IBRECNO - ien in [EVENTS] multiple
;output:
; record number if success
; 0 if failure
INS(IBDARR,IBDTIEN,IBRECNO) ;
N IBSET1,IBSET2,IBSET3,IBFLDNO,IBINSNO,RECNO,IBVAL
S IBINSNO=0
; Only create entry for first insurance found. BNT 07/07/2010
F S IBINSNO=$O(IBDARR("INS",IBINSNO)) Q:+IBINSNO=0 D Q:$D(RECNO)
. S IBSET1=$G(IBDARR("INS",IBINSNO,1))
. S IBSET2=$G(IBDARR("INS",IBINSNO,2))
. S IBSET3=$G(IBDARR("INS",IBINSNO,3))
. S RECNO=$$ADDINS(IBDTIEN,IBRECNO)
. I +$$FILLFLDS^IBNCPUT1(366.1412,.02,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET1,U,1))
. I +$$FILLFLDS^IBNCPUT1(366.1412,.03,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET1,U,2))
. I +$$FILLFLDS^IBNCPUT1(366.1412,.04,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET1,U,3))
. I +$$FILLFLDS^IBNCPUT1(366.1412,.05,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET1,U,4))
. I +$$FILLFLDS^IBNCPUT1(366.1412,.06,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET1,U,5))
. I +$$FILLFLDS^IBNCPUT1(366.1412,.07,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET1,U,6))
. I +$$FILLFLDS^IBNCPUT1(366.1412,.08,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET1,U,7))
. I +$$FILLFLDS^IBNCPUT1(366.1412,.09,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET1,U,20))
. ;
. I +$$FILLFLDS^IBNCPUT1(366.1412,.101,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET1,U,8))
. I +$$FILLFLDS^IBNCPUT1(366.1412,.102,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET1,U,9))
. I +$$FILLFLDS^IBNCPUT1(366.1412,.103,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET1,U,10))
. I +$$FILLFLDS^IBNCPUT1(366.1412,.104,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET1,U,11))
. I +$$FILLFLDS^IBNCPUT1(366.1412,.105,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET1,U,12))
. I +$$FILLFLDS^IBNCPUT1(366.1412,.106,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET1,U,13))
. I +$$FILLFLDS^IBNCPUT1(366.1412,.107,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET1,U,14))
. ;
. I +$$FILLFLDS^IBNCPUT1(366.1412,.201,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET2,U,1))
. I +$$FILLFLDS^IBNCPUT1(366.1412,.202,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET2,U,2))
. I +$$FILLFLDS^IBNCPUT1(366.1412,.203,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET2,U,3))
. I +$$FILLFLDS^IBNCPUT1(366.1412,.204,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET2,U,4))
. I +$$FILLFLDS^IBNCPUT1(366.1412,.205,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET2,U,5))
. I +$$FILLFLDS^IBNCPUT1(366.1412,.206,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET2,U,6))
. I +$$FILLFLDS^IBNCPUT1(366.1412,.207,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET2,U,7))
. ;
. I +$$FILLFLDS^IBNCPUT1(366.1412,.301,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET3,U,1))
. I +$$FILLFLDS^IBNCPUT1(366.1412,.302,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET3,U,2))
. I +$$FILLFLDS^IBNCPUT1(366.1412,.303,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET3,U,3))
. I +$$FILLFLDS^IBNCPUT1(366.1412,.304,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET3,U,7))
. Q
;
Q RECNO
;create top level entry in #366.14
;input:
; IBDATE - date in FileMan format
;output
; returns ien created
ADDDATE(IBDATE) ;
N IBIEN
S IBIEN=+$O(^IBCNR(366.14,"B",IBDATE,0))
I IBIEN>0 Q IBIEN
I $$INSITEM^IBNCPUT1(366.14,"",IBDATE,"")
Q +$O(^IBCNR(366.14,"B",IBDATE,0))
;
;create EVENT entry in #366.14
;input:
;IBIEN - ien on top [DATE] level
;EVNTTYPE event type (value for .01)
;returns ien for the event
;or 0 if failed
NEWEVENT(IBIEN,EVNTTYPE) ;
N EVNTRECN
S EVNTRECN=$$INSITEM^IBNCPUT1(366.141,IBIEN,$$EXT2INT^IBNCPUT1(EVNTTYPE),"","")
I EVNTRECN>0 Q EVNTRECN
Q 0
;
;add insurance node
;IBDTIEN - ien on top [DATE] level
;IBEVIEN - ien in [EVENTS] multiple
;returns :
; new ien in INSURANCE multiple
ADDINS(IBDTIEN,IBEVIEN) ;
N IBX,IBX2
F IBX=1:1:99999 I '$D(^IBCNR(366.14,IBDTIEN,1,IBEVIEN,5,IBX)) D Q
. S IBX2=$$INSITEM^IBNCPUT1(366.1412,IBEVIEN_","_IBDTIEN,IBX,IBX)
Q +$O(^IBCNR(366.14,IBDTIEN,1,IBEVIEN,5,"B",IBX,0))
;
GETREAS(REASON) ;
; Get the pointer of the IB NCPDP NON-BILLABLE REASON file - Create the
; entry if needed.
;
; Input:
; REASON: Non-billable reason text
; Output:
; IEN of the IB NCPPD NON-BILLABLE REASON file
;
I $G(REASON)="" Q ""
N NBSTS,DIC,X,Y,DTOUT,DUOUT
;
; Make uppercase and less than 60 characters
S REASON=$TR($E($$UP^XLFSTR(REASON),1,60),"^")
I $E(REASON,$L(REASON))="." S REASON=$E(REASON,1,$L(REASON)-1)
;
; Check if it already exists. If so, return the IEN
S NBSTS=$O(^IBCNR(366.17,"B",REASON,""))
I NBSTS Q NBSTS
;
; If it does not exist not, add to the dictionary
S DIC="^IBCNR(366.17,",DIC(0)="F",X=REASON
D FILE^DICN
I Y=-1 Q ""
Q +Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBNCPLOG 11954 printed Nov 22, 2024@17:35:05 Page 2
IBNCPLOG ;BHAM ISC/SS - IB ECME EVNT REPORT ;3/5/08 14:02
+1 ;;2.0;INTEGRATED BILLING;**342,339,363,383,411,435,452,534,550,647**;21-MAR-94;Build 10
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;store data related to the IB calls made by ECME package in the file #366.14
+5 ;input:
+6 ;.IBIBD - (by reference) IBD array with parameter sent to IB by ECME
+7 ;DFN patient's ien
+8 ;IBPROC - type of event. i.e. content of CALL such as BILL, REJECT and so on
+9 ;IBRESULT - (optional) result of the event processing, format: return_code^message
+10 ;IBJOB - (optional) job, default = $J
+11 ;IBDTTM - (optional) datetime, default = "NOW"
+12 ;IBUSR - (optional) user ID, default = DUZ
+13 ;output:
+14 ;none
LOG(IBIBD,DFN,IBPROC,IBRESULT,IBJOB,IBDTTM,IBUSR) ;Store the data
+1 NEW NDX,Z,REF,IBDATE,IBDTIEN,IBEVNIEN,IBIBDTYP,IBRETV,IBPTR
+2 SET IBRESULT=$GET(IBRESULT)
+3 ;
+4 IF '$GET(IBJOB)
SET IBJOB=$JOB
+5 IF '$GET(IBDTTM)
SET IBDTTM=$$NOW^XLFDT()
+6 IF '$GET(IBUSR)
SET IBUSR=+DUZ
+7 ;
+8 SET IBDATE=DT
+9 SET IBDTIEN=+$ORDER(^IBCNR(366.14,"B",IBDATE,0))
+10 LOCK +^IBCNR(366.14):30
IF '$TEST
QUIT
+11 IF IBDTIEN=0
SET IBDTIEN=+$$ADDDATE(IBDATE)
+12 ;create an event
+13 SET IBEVNIEN=$$NEWEVENT(IBDTIEN,IBPROC)
+14 LOCK -^IBCNR(366.14)
+15 IF IBEVNIEN=0
WRITE !,"New event creation Error : LOG^IBNCPLOG",!
QUIT
+16 ;
+17 ;DFN
IF +$$FILLFLDS^IBNCPUT1(366.141,".03",IBEVNIEN_","_IBDTIEN,DFN)
+18 ;JOB
IF +$$FILLFLDS^IBNCPUT1(366.141,".04",IBEVNIEN_","_IBDTIEN,IBJOB)
+19 ;DATETIME
IF +$$FILLFLDS^IBNCPUT1(366.141,".05",IBEVNIEN_","_IBDTIEN,IBDTTM)
+20 ;USER
IF +$$FILLFLDS^IBNCPUT1(366.141,".06",IBEVNIEN_","_IBDTIEN,DUZ)
+21 IF IBRESULT'=""
Begin DoDot:1
+22 ;RESULT
SET IBRETV=+$$FILLFLDS^IBNCPUT1(366.141,".07",IBEVNIEN_","_IBDTIEN,+IBRESULT)
+23 ;RESULT MESSAGE
SET IBRETV=+$$FILLFLDS^IBNCPUT1(366.141,".08",IBEVNIEN_","_IBDTIEN,$PIECE(IBRESULT,U,2))
+24 IF IBPROC="BILLABLE STATUS CHECK"
IF $PIECE(IBRESULT,U,2)]""
Begin DoDot:2
+25 SET IBPTR=$$GETREAS($PIECE(IBRESULT,U,2))
+26 ; Non-Billable Status Reason
IF IBPTR
SET IBRETV=+$$FILLFLDS^IBNCPUT1(366.141,".02",IBEVNIEN_","_IBDTIEN,IBPTR)
End DoDot:2
+27 ; Eligibility from IB billing determination (IB*2*452)
IF $PIECE(IBRESULT,U,3)'=""
SET IBRETV=+$$FILLFLDS^IBNCPUT1(366.141,"7.05",IBEVNIEN_","_IBDTIEN,$PIECE(IBRESULT,U,3))
+28 QUIT
End DoDot:1
+29 ;
+30 ;store IBIBD array
+31 SET IBIBDTYP=""
+32 FOR
SET IBIBDTYP=$ORDER(IBIBD(IBIBDTYP))
if IBIBDTYP=""
QUIT
Begin DoDot:1
+33 DO IBD(IBDTIEN,IBEVNIEN,IBIBDTYP,$GET(IBIBD(IBIBDTYP)),.IBIBD)
End DoDot:1
+34 ;store "INS" node of IBIBD array
+35 IF $DATA(IBIBD("INS"))
IF $$INS(.IBIBD,IBDTIEN,IBEVNIEN)
+36 QUIT
+37 ;
+38 ;store IBD array data
+39 ;IBDTIEN - ien on top [DATE] level
+40 ;IBRECNO - ien in [EVENTS] multiple
+41 ;IBIBDTYP - type subscript in IBD array (BILL, PAID, RESPONSE, etc)
+42 ;IBVAL - value to store
+43 ;IBIBD - array with data passed by reference (for efficiency)
IBD(IBDTIEN,IBRECNO,IBIBDTYP,IBVAL,IBIBD) ;
+1 NEW IBFLDNO
+2 ;W !," - ",IBRECNO," ",IBIBDTYP," = ",IBVAL
+3 ;free text like "WEBMD: PAID"
+4 IF IBIBDTYP="AUTH #"
SET IBFLDNO=".11"
SET IBVAL=$EXTRACT(IBVAL,1,30)
GOTO EDITIBD
+5 ;free text like "0504597;3051229"
+6 IF IBIBDTYP="BCID"
SET IBFLDNO=".12"
GOTO EDITIBD
+7 ;7 or 12 digit ECME number - identifier (stored as a text - might have leading zeroes)
+8 IF IBIBDTYP="CLAIMID"
SET IBFLDNO=".13"
GOTO EDITIBD
+9 ;pointer to file #2
+10 IF IBIBDTYP="DFN"
SET IBFLDNO=".14"
GOTO EDITIBD
+11 ;pointer to file #40.8
+12 IF IBIBDTYP="DIVISION"
SET IBFLDNO=".15"
GOTO EDITIBD
+13 ;free text
+14 IF IBIBDTYP="RESPONSE"
SET IBFLDNO=".16"
SET IBVAL=$EXTRACT(IBVAL,1,20)
GOTO EDITIBD
+15 ;free text
+16 IF IBIBDTYP="REVERSAL REASON"
SET IBFLDNO=".17"
SET IBVAL=$EXTRACT(IBVAL,1,40)
GOTO EDITIBD
+17 ;1 digit number
+18 IF IBIBDTYP="RTS-DEL"
SET IBFLDNO=".18"
GOTO EDITIBD
+19 ;free text
+20 IF IBIBDTYP="STATUS"
SET IBFLDNO=".19"
SET IBVAL=$EXTRACT(IBVAL,1,20)
GOTO EDITIBD
+21 ;Prescription number as a text, might have alpha characters (external value, this is not IEN)
+22 IF IBIBDTYP="RX NO"
SET IBFLDNO=".202"
SET IBVAL=$EXTRACT(IBVAL,1,20)
GOTO EDITIBD
+23 ;0 - original, 1,2,3,... - refill number
+24 IF IBIBDTYP="FILL NUMBER"
SET IBFLDNO=".203"
GOTO EDITIBD
+25 ;internal identifier number for a DRUG
+26 IF IBIBDTYP="DRUG"
SET IBFLDNO=".204"
GOTO EDITIBD
+27 IF IBIBDTYP="NDC"
SET IBFLDNO=".205"
GOTO EDITIBD
+28 IF IBIBDTYP="DOS"
SET IBFLDNO=".206"
GOTO EDITIBD
+29 IF IBIBDTYP="RELEASE DATE"
SET IBFLDNO=".207"
GOTO EDITIBD
+30 IF IBIBDTYP="QTY"
SET IBFLDNO=".208"
GOTO EDITIBD
+31 IF IBIBDTYP="UNITS"
SET IBFLDNO=".213"
GOTO EDITIBD
+32 IF IBIBDTYP="NCPDP QTY"
SET IBFLDNO=".214"
GOTO EDITIBD
+33 IF IBIBDTYP="NCPDP UNITS"
SET IBFLDNO=".215"
GOTO EDITIBD
+34 IF IBIBDTYP="DAYS SUPPLY"
SET IBFLDNO=".209"
GOTO EDITIBD
+35 IF IBIBDTYP="DEA"
SET IBFLDNO=".21"
GOTO EDITIBD
+36 IF IBIBDTYP="FILLED BY"
SET IBFLDNO=".211"
GOTO EDITIBD
+37 IF IBIBDTYP="COPAY"
SET IBFLDNO=".311"
GOTO EDITIBD
+38 IF IBIBDTYP="ING COST PAID"
SET IBFLDNO=".312"
GOTO EDITIBD
+39 IF IBIBDTYP="DISP FEE PAID"
SET IBFLDNO=".313"
GOTO EDITIBD
+40 IF IBIBDTYP="PAT RESP"
SET IBFLDNO=".314"
GOTO EDITIBD
+41 ; for environmental indicators:
+42 ; if IBIBD("SC/EI OVR")=1 - the user overrides any answers (3)
+43 ; if $G(IBIBD("SC/EI NO ANSW")) contains the IBIBDTYP - this question was not answered (2)
+44 ; otherwise - use whatever in the IBVAL (0 - NO, 1 -YES)
+45 IF IBIBDTYP="AO"
SET IBFLDNO=".401"
SET IBVAL=$SELECT($GET(IBIBD("SC/EI OVR"))=1:3,(","_$GET(IBIBD("SC/EI NO ANSW"))_",")[(","_IBIBDTYP_","):2,1:IBVAL)
GOTO EDITIBD
+46 IF IBIBDTYP="CV"
SET IBFLDNO=".402"
SET IBVAL=$SELECT($GET(IBIBD("SC/EI OVR"))=1:3,(","_$GET(IBIBD("SC/EI NO ANSW"))_",")[(","_IBIBDTYP_","):2,1:IBVAL)
GOTO EDITIBD
+47 IF IBIBDTYP="SWA"
SET IBFLDNO=".403"
SET IBVAL=$SELECT($GET(IBIBD("SC/EI OVR"))=1:3,(","_$GET(IBIBD("SC/EI NO ANSW"))_",")[(","_IBIBDTYP_","):2,1:IBVAL)
GOTO EDITIBD
+48 IF IBIBDTYP="IR"
SET IBFLDNO=".404"
SET IBVAL=$SELECT($GET(IBIBD("SC/EI OVR"))=1:3,(","_$GET(IBIBD("SC/EI NO ANSW"))_",")[(","_IBIBDTYP_","):2,1:IBVAL)
GOTO EDITIBD
+49 IF IBIBDTYP="MST"
SET IBFLDNO=".405"
SET IBVAL=$SELECT($GET(IBIBD("SC/EI OVR"))=1:3,(","_$GET(IBIBD("SC/EI NO ANSW"))_",")[(","_IBIBDTYP_","):2,1:IBVAL)
GOTO EDITIBD
+50 IF IBIBDTYP="HNC"
SET IBFLDNO=".406"
SET IBVAL=$SELECT($GET(IBIBD("SC/EI OVR"))=1:3,(","_$GET(IBIBD("SC/EI NO ANSW"))_",")[(","_IBIBDTYP_","):2,1:IBVAL)
GOTO EDITIBD
+51 IF IBIBDTYP="SC"
SET IBFLDNO=".407"
SET IBVAL=$SELECT($GET(IBIBD("SC/EI OVR"))=1:3,(","_$GET(IBIBD("SC/EI NO ANSW"))_",")[(","_IBIBDTYP_","):2,1:IBVAL)
GOTO EDITIBD
+52 IF IBIBDTYP="SHAD"
SET IBFLDNO=".408"
SET IBVAL=$SELECT($GET(IBIBD("SC/EI OVR"))=1:3,(","_$GET(IBIBD("SC/EI NO ANSW"))_",")[(","_IBIBDTYP_","):2,1:IBVAL)
GOTO EDITIBD
+53 IF IBIBDTYP="ACT DTY OVR"
SET IBFLDNO=".409"
GOTO EDITIBD
+54 IF IBIBDTYP="BILL"
SET IBFLDNO=".301"
GOTO EDITIBD
+55 IF IBIBDTYP="BILLED"
SET IBFLDNO=".302"
GOTO EDITIBD
+56 IF IBIBDTYP="PLAN"
SET IBFLDNO=".303"
GOTO EDITIBD
+57 IF IBIBDTYP="COST"
SET IBFLDNO=".304"
GOTO EDITIBD
+58 IF IBIBDTYP="PAID"
SET IBFLDNO=".305"
GOTO EDITIBD
+59 IF IBIBDTYP="CLOSE COMMENT"
SET IBFLDNO=".306"
GOTO EDITIBD
+60 IF IBIBDTYP="REOPEN COMMENT"
SET IBFLDNO=".306"
GOTO EDITIBD
+61 IF IBIBDTYP="CLOSE REASON"
SET IBFLDNO=".307"
GOTO EDITIBD
+62 IF IBIBDTYP="DROP TO PAPER"
SET IBFLDNO=".308"
GOTO EDITIBD
+63 IF IBIBDTYP="RELEASE COPAY"
SET IBFLDNO=".309"
GOTO EDITIBD
+64 IF IBIBDTYP="USER"
SET IBFLDNO=".31"
GOTO EDITIBD
+65 IF IBIBDTYP="PRESCRIPTION"
SET IBFLDNO=".201"
GOTO EDITIBD
+66 IF IBIBDTYP="IEN"
SET IBFLDNO=".212"
GOTO EDITIBD
+67 IF IBIBDTYP="EPHARM"
SET IBFLDNO=".09"
GOTO EDITIBD
+68 IF IBIBDTYP="RXCOB"
SET IBFLDNO="7.01"
GOTO EDITIBD
+69 IF IBIBDTYP="PRIMARY BILL"
SET IBFLDNO="7.02"
GOTO EDITIBD
+70 IF IBIBDTYP="PRIOR PAYMENT"
SET IBFLDNO="7.03"
GOTO EDITIBD
+71 IF IBIBDTYP="RTYPE"
SET IBFLDNO="7.04"
GOTO EDITIBD
+72 IF IBIBDTYP="DRUG-BILLABLE"
SET IBFLDNO=7.06
GOTO EDITIBD
+73 IF IBIBDTYP="DRUG-BILLABLE TRICARE"
SET IBFLDNO=7.07
GOTO EDITIBD
+74 IF IBIBDTYP="DRUG-BILLABLE CHAMPVA"
SET IBFLDNO=7.08
GOTO EDITIBD
+75 IF IBIBDTYP="DRUG-SENSITIVE DX"
SET IBFLDNO=7.09
GOTO EDITIBD
+76 QUIT 0
EDITIBD ;
+1 QUIT +$$FILLFLDS^IBNCPUT1(366.141,IBFLDNO,IBRECNO_","_IBDTIEN,IBVAL)
+2 ;------
+3 ;to store IBD("INS") array data
+4 ;input:
+5 ;IBDARR - IBD array by reference
+6 ;IBDTIEN - ien on top [DATE] level
+7 ;IBRECNO - ien in [EVENTS] multiple
+8 ;output:
+9 ; record number if success
+10 ; 0 if failure
INS(IBDARR,IBDTIEN,IBRECNO) ;
+1 NEW IBSET1,IBSET2,IBSET3,IBFLDNO,IBINSNO,RECNO,IBVAL
+2 SET IBINSNO=0
+3 ; Only create entry for first insurance found. BNT 07/07/2010
+4 FOR
SET IBINSNO=$ORDER(IBDARR("INS",IBINSNO))
if +IBINSNO=0
QUIT
Begin DoDot:1
+5 SET IBSET1=$GET(IBDARR("INS",IBINSNO,1))
+6 SET IBSET2=$GET(IBDARR("INS",IBINSNO,2))
+7 SET IBSET3=$GET(IBDARR("INS",IBINSNO,3))
+8 SET RECNO=$$ADDINS(IBDTIEN,IBRECNO)
+9 IF +$$FILLFLDS^IBNCPUT1(366.1412,.02,RECNO_","_IBRECNO_","_IBDTIEN,$PIECE(IBSET1,U,1))
+10 IF +$$FILLFLDS^IBNCPUT1(366.1412,.03,RECNO_","_IBRECNO_","_IBDTIEN,$PIECE(IBSET1,U,2))
+11 IF +$$FILLFLDS^IBNCPUT1(366.1412,.04,RECNO_","_IBRECNO_","_IBDTIEN,$PIECE(IBSET1,U,3))
+12 IF +$$FILLFLDS^IBNCPUT1(366.1412,.05,RECNO_","_IBRECNO_","_IBDTIEN,$PIECE(IBSET1,U,4))
+13 IF +$$FILLFLDS^IBNCPUT1(366.1412,.06,RECNO_","_IBRECNO_","_IBDTIEN,$PIECE(IBSET1,U,5))
+14 IF +$$FILLFLDS^IBNCPUT1(366.1412,.07,RECNO_","_IBRECNO_","_IBDTIEN,$PIECE(IBSET1,U,6))
+15 IF +$$FILLFLDS^IBNCPUT1(366.1412,.08,RECNO_","_IBRECNO_","_IBDTIEN,$PIECE(IBSET1,U,7))
+16 IF +$$FILLFLDS^IBNCPUT1(366.1412,.09,RECNO_","_IBRECNO_","_IBDTIEN,$PIECE(IBSET1,U,20))
+17 ;
+18 IF +$$FILLFLDS^IBNCPUT1(366.1412,.101,RECNO_","_IBRECNO_","_IBDTIEN,$PIECE(IBSET1,U,8))
+19 IF +$$FILLFLDS^IBNCPUT1(366.1412,.102,RECNO_","_IBRECNO_","_IBDTIEN,$PIECE(IBSET1,U,9))
+20 IF +$$FILLFLDS^IBNCPUT1(366.1412,.103,RECNO_","_IBRECNO_","_IBDTIEN,$PIECE(IBSET1,U,10))
+21 IF +$$FILLFLDS^IBNCPUT1(366.1412,.104,RECNO_","_IBRECNO_","_IBDTIEN,$PIECE(IBSET1,U,11))
+22 IF +$$FILLFLDS^IBNCPUT1(366.1412,.105,RECNO_","_IBRECNO_","_IBDTIEN,$PIECE(IBSET1,U,12))
+23 IF +$$FILLFLDS^IBNCPUT1(366.1412,.106,RECNO_","_IBRECNO_","_IBDTIEN,$PIECE(IBSET1,U,13))
+24 IF +$$FILLFLDS^IBNCPUT1(366.1412,.107,RECNO_","_IBRECNO_","_IBDTIEN,$PIECE(IBSET1,U,14))
+25 ;
+26 IF +$$FILLFLDS^IBNCPUT1(366.1412,.201,RECNO_","_IBRECNO_","_IBDTIEN,$PIECE(IBSET2,U,1))
+27 IF +$$FILLFLDS^IBNCPUT1(366.1412,.202,RECNO_","_IBRECNO_","_IBDTIEN,$PIECE(IBSET2,U,2))
+28 IF +$$FILLFLDS^IBNCPUT1(366.1412,.203,RECNO_","_IBRECNO_","_IBDTIEN,$PIECE(IBSET2,U,3))
+29 IF +$$FILLFLDS^IBNCPUT1(366.1412,.204,RECNO_","_IBRECNO_","_IBDTIEN,$PIECE(IBSET2,U,4))
+30 IF +$$FILLFLDS^IBNCPUT1(366.1412,.205,RECNO_","_IBRECNO_","_IBDTIEN,$PIECE(IBSET2,U,5))
+31 IF +$$FILLFLDS^IBNCPUT1(366.1412,.206,RECNO_","_IBRECNO_","_IBDTIEN,$PIECE(IBSET2,U,6))
+32 IF +$$FILLFLDS^IBNCPUT1(366.1412,.207,RECNO_","_IBRECNO_","_IBDTIEN,$PIECE(IBSET2,U,7))
+33 ;
+34 IF +$$FILLFLDS^IBNCPUT1(366.1412,.301,RECNO_","_IBRECNO_","_IBDTIEN,$PIECE(IBSET3,U,1))
+35 IF +$$FILLFLDS^IBNCPUT1(366.1412,.302,RECNO_","_IBRECNO_","_IBDTIEN,$PIECE(IBSET3,U,2))
+36 IF +$$FILLFLDS^IBNCPUT1(366.1412,.303,RECNO_","_IBRECNO_","_IBDTIEN,$PIECE(IBSET3,U,3))
+37 IF +$$FILLFLDS^IBNCPUT1(366.1412,.304,RECNO_","_IBRECNO_","_IBDTIEN,$PIECE(IBSET3,U,7))
+38 QUIT
End DoDot:1
if $DATA(RECNO)
QUIT
+39 ;
+40 QUIT RECNO
+41 ;create top level entry in #366.14
+42 ;input:
+43 ; IBDATE - date in FileMan format
+44 ;output
+45 ; returns ien created
ADDDATE(IBDATE) ;
+1 NEW IBIEN
+2 SET IBIEN=+$ORDER(^IBCNR(366.14,"B",IBDATE,0))
+3 IF IBIEN>0
QUIT IBIEN
+4 IF $$INSITEM^IBNCPUT1(366.14,"",IBDATE,"")
+5 QUIT +$ORDER(^IBCNR(366.14,"B",IBDATE,0))
+6 ;
+7 ;create EVENT entry in #366.14
+8 ;input:
+9 ;IBIEN - ien on top [DATE] level
+10 ;EVNTTYPE event type (value for .01)
+11 ;returns ien for the event
+12 ;or 0 if failed
NEWEVENT(IBIEN,EVNTTYPE) ;
+1 NEW EVNTRECN
+2 SET EVNTRECN=$$INSITEM^IBNCPUT1(366.141,IBIEN,$$EXT2INT^IBNCPUT1(EVNTTYPE),"","")
+3 IF EVNTRECN>0
QUIT EVNTRECN
+4 QUIT 0
+5 ;
+6 ;add insurance node
+7 ;IBDTIEN - ien on top [DATE] level
+8 ;IBEVIEN - ien in [EVENTS] multiple
+9 ;returns :
+10 ; new ien in INSURANCE multiple
ADDINS(IBDTIEN,IBEVIEN) ;
+1 NEW IBX,IBX2
+2 FOR IBX=1:1:99999
IF '$DATA(^IBCNR(366.14,IBDTIEN,1,IBEVIEN,5,IBX))
Begin DoDot:1
+3 SET IBX2=$$INSITEM^IBNCPUT1(366.1412,IBEVIEN_","_IBDTIEN,IBX,IBX)
End DoDot:1
QUIT
+4 QUIT +$ORDER(^IBCNR(366.14,IBDTIEN,1,IBEVIEN,5,"B",IBX,0))
+5 ;
GETREAS(REASON) ;
+1 ; Get the pointer of the IB NCPDP NON-BILLABLE REASON file - Create the
+2 ; entry if needed.
+3 ;
+4 ; Input:
+5 ; REASON: Non-billable reason text
+6 ; Output:
+7 ; IEN of the IB NCPPD NON-BILLABLE REASON file
+8 ;
+9 IF $GET(REASON)=""
QUIT ""
+10 NEW NBSTS,DIC,X,Y,DTOUT,DUOUT
+11 ;
+12 ; Make uppercase and less than 60 characters
+13 SET REASON=$TRANSLATE($EXTRACT($$UP^XLFSTR(REASON),1,60),"^")
+14 IF $EXTRACT(REASON,$LENGTH(REASON))="."
SET REASON=$EXTRACT(REASON,1,$LENGTH(REASON)-1)
+15 ;
+16 ; Check if it already exists. If so, return the IEN
+17 SET NBSTS=$ORDER(^IBCNR(366.17,"B",REASON,""))
+18 IF NBSTS
QUIT NBSTS
+19 ;
+20 ; If it does not exist not, add to the dictionary
+21 SET DIC="^IBCNR(366.17,"
SET DIC(0)="F"
SET X=REASON
+22 DO FILE^DICN
+23 IF Y=-1
QUIT ""
+24 QUIT +Y
