- IBNCPEV1 ;DALOI/SS - NCPDP BILLING EVENTS REPORT ;21-MAR-2006
- ;;2.0;INTEGRATED BILLING;**342,339,363,411,435,452,516,550,647**;21-MAR-94;Build 10
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- ;IA# 10155 is used to read ^DD(file,field,0) node
- Q
- ;
- SETVARS ;
- ;newed in IBNCPEV
- S (IBECME,IBPAT,IBRX,IBQ,IBSCR,IBPAGE,IBDTL,IBDIVS)=0
- ;date
- F D DATE^IBNCPDPE Q:IBQ Q:$$TESTDATA^IBNCPDPE
- Q:IBQ
- N IBMLTDV S IBMLTDV=$$MULTPHRM^BPSUTIL()
- I +IBMLTDV=1 S IBDIVS=+$$MULTIDIV(.IBDIVS) S:IBDIVS=0 IBDIVS(0)="0^ALL" I IBDIVS=-1 S IBQ=1 Q
- I +IBMLTDV=0 S IBDIVS=0,IBDIVS(0)="0^"_$P(IBMLTDV,U,2)
- D MODE^IBNCPDPE Q:IBQ
- D DEVICE^IBNCPDPE Q:IBQ
- Q
- ;
- ;/**
- GETRX(IBECMENO,IBST,IBEND,IBECME) ; get ien of file 52 from #366.14
- ; input -
- ; IBECMENO = ECME # input from the user (with or without leading zeros)
- ; IBST = start date (FM format)
- ; IBEND = end date (FM format)
- ; output - function value: returns internal entry number of file #52 for the earliest date within the date range
- ; IBECME - output variable pass by reference. Returns the external version of the ECME# with leading zeros
- ;
- ; This subroutine is called when the user enters an ECME# as part of the search criteria
- ;
- N IBDATE,IBNO,IBIEN,IBFOUND,IBRXIEN,ECMELEN,IBRXIEN
- S (IBFOUND,IBRXIEN)=0
- F ECMELEN=12,7 D Q:IBFOUND
- . I $L(+IBECMENO)>ECMELEN Q
- . S IBECMENO=$$RJ^XLFSTR(+IBECMENO,ECMELEN,0) ; build ECME# with leading zeros to proper length
- . S IBDATE=+$O(^IBCNR(366.14,"E",IBECMENO,IBST-1)) Q:'IBDATE
- . I IBDATE>IBEND Q
- . S IBNO=+$O(^IBCNR(366.14,"E",IBECMENO,IBDATE,0)) Q:'IBNO
- . S IBIEN=+$O(^IBCNR(366.14,"B",IBDATE,0)) Q:'IBIEN
- . S IBRXIEN=+$P($G(^IBCNR(366.14,IBIEN,1,IBNO,2)),U,1)
- . I IBRXIEN S IBFOUND=1,IBECME=IBECMENO Q
- . Q
- Q IBRXIEN
- ;
- DSTAT(IBD0,IBD2,IBD3,IBD4,IBINS,IBD7) ; finish event/IB Billing Determination event
- ;input:
- ;IBD0 - node ^IBCNR(366.14,D0,1,D1,0)
- ;IBD2 - node ^IBCNR(366.14,D0,1,D1,2)
- ;IBD3 - node ^IBCNR(366.14,D0,1,D1,3)
- ;IBD4 - node ^IBCNR(366.14,D0,1,D1,4)
- ;IBINS - multiple of ^IBCNR(366.14,D0,1,D1,5)
- ;IBD7 - node ^IBCNR(366.14,D0,1,D1,7)
- ;
- N IBX,IBT,IBSC,IB1ST,IBNXT,IBEXMPV
- S IB1ST=1
- D CHKP^IBNCPEV Q:IBQ
- ;
- W !?10,"ELIGIBILITY: "
- W $$EXTERNAL^DILFD(366.141,7.05,,$P(IBD7,U,5)) ; esg - 5/1/11 - IB*2*452
- ;
- W !?10,"EI/SC INDICATORS: "
- F IBX=2:1 S IBT=$P($T(EXEMPT+IBX^IBNCPDP1),";",3),IBSC=$P(IBT,U,2) Q:IBSC="" S IBEXMPV=$$EXMPFLDS(IBSC,IBD4) D:IBEXMPV]"" Q:IBQ!(IBEXMPV=3)
- . I IBEXMPV=3 W "overridden by the user" Q
- . I 'IB1ST W "," I $X>70 D CHKP^IBNCPEV Q:IBQ W !?10 S IB1ST=1
- . W " ",IBSC,":",$S(IBEXMPV=1:"Yes",IBEXMPV=0:"No",IBEXMPV=2:"No Answer",1:"?") S IB1ST=0
- Q:IBQ
- ;
- I $P(IBD4,U,9) W !?10,"ACTIVE DUTY: Yes"
- ;
- I $P(IBD2,U,4) D CHKP^IBNCPEV Q:IBQ W !?10,"DRUG:",$$DRUGNAM(+$P(IBD2,U,4))
- ;
- ; esg - 9/29/15 - IB*2*550 - Display Drug file ECME billable fields
- I ($P(IBD7,U,6)=0)!($P(IBD7,U,7)=0)!($P(IBD7,U,8)=0) D Q:IBQ
- . I $P(IBD0,U,7) Q ; billable result - no display
- . I $P(IBD7,U,5)="V",$P(IBD7,U,6) Q ; veteran, drug billable - no display
- . I $P(IBD7,U,5)="T",$P(IBD7,U,6),$P(IBD7,U,7) Q ; tricare, drug billable - no display
- . I $P(IBD7,U,5)="C",$P(IBD7,U,6),$P(IBD7,U,8) Q ; champva, drug billable - no display
- . D CHKP^IBNCPEV Q:IBQ
- . W !?10,"DRUG ECME BILLABLE: ",$S($P(IBD7,U,6):"Yes",1:"No")
- . I $P(IBD7,U,5)="T" D CHKP^IBNCPEV Q:IBQ W !?10,"DRUG ECME BILLABLE (TRICARE): ",$S($P(IBD7,U,7):"Yes",1:"No")
- . I $P(IBD7,U,5)="C" D CHKP^IBNCPEV Q:IBQ W !?10,"DRUG ECME BILLABLE (CHAMPVA): ",$S($P(IBD7,U,8):"Yes",1:"No")
- . Q
- ;
- ; esg - 9/29/15 - IB*2*550 - Display sensitive diagnosis drug if not billable and the message contains "ROI"
- I $P(IBD7,U,9),'$P(IBD0,U,7),$P(IBD0,U,8)["ROI" D Q:IBQ
- . D CHKP^IBNCPEV Q:IBQ
- . W !?10,"SENSITIVE DIAGNOSIS DRUG: Yes"
- . Q
- ;
- D CHKP^IBNCPEV Q:IBQ
- W !?10,"NDC:",$S($P(IBD2,U,5):$P(IBD2,U,5),1:"No")
- W ", NCPDP QTY:",$S($P(IBD2,U,14):$P(IBD2,U,14),1:"No")
- W $$UNITDISP($P(IBD2,U,14),$P(IBD2,U,15)) ; display NCPDP unit type
- ;
- D CHKP^IBNCPEV Q:IBQ
- W !?10,"BILLED QTY:",$S($P(IBD2,U,8):$P(IBD2,U,8),1:"No")
- W $$UNITDISP($P(IBD2,U,8),$P(IBD2,U,13)) ; display billing unit type
- W ", UNIT COST:",$S($P(IBD3,U,4):$P(IBD3,U,4),1:"No")
- I $P(IBD2,U,10)]"" W ", DEA:",$P(IBD2,U,10)
- ;
- ; display insurance subfile data
- S IBX=0,IBNXT=0 F S IBX=$O(IBINS(IBX)) Q:'IBX D Q:IBQ S IBNXT=1
- . N Y,Y3,PLANIEN
- . S Y=$G(IBINS(IBX,0))
- . S PLANIEN=+$P(Y,U,2) I 'PLANIEN W "@@@@" Q
- . I IBNXT D CHKP^IBNCPEV Q:IBQ W !?10,"-----------"
- . D CHKP^IBNCPEV Q:IBQ W !?10
- . ;
- . ;IB*2.0*516/baa - Use HIPAA compliant fields
- . W "PLAN:",$$GET1^DIQ(355.3,PLANIEN_",",2.01)
- . W ", INSURANCE:",$$GET1^DIQ(355.3,PLANIEN_",",.01,"E")
- . I +IBD7>0 W ", COB:",$S(+IBD7=2:"S",1:"P")
- . ;
- . ; display pharmacy plan ID and name
- . D CHKP^IBNCPEV Q:IBQ
- . S Y3=$G(IBINS(IBX,3))
- . W !?10,"PHARMACY PLAN:",$S($L($P(Y3,U,3)):$$PLANID($P(Y3,U,3)),1:"N/A")
- . ;
- . D CHKP^IBNCPEV Q:IBQ W !?10 S IB1ST=1
- . I $P(Y,U,3)]"" W "BIN:",$P(Y,U,3) S IB1ST=0
- . I $P(Y,U,4)]"" W:'IB1ST ", " W "PCN:",$P(Y,U,4) S IB1ST=0
- . I $P(Y,U,5)]"" W:'IB1ST ", " W "PAYER SHEET B1:",$P(Y,U,5) S IB1ST=0
- . ;
- . D CHKP^IBNCPEV Q:IBQ W !?10 S IB1ST=1
- . S Y=$G(IBINS(IBX,1))
- . I $P(Y,U,4)]"" W "PAYER SHEET B2:",$P(Y,U,4) S IB1ST=0
- . I $P(Y,U,5)]"" W:'IB1ST ", " W "PAYER SHEET B3:",$P(Y,U,5)
- . ;
- . D CHKP^IBNCPEV Q:IBQ
- . S Y=$G(IBINS(IBX,2))
- . W !?10,"BASIS OF COST DETERM:",$S($L($P(Y,U,2)):$$BOCD^IBNCPEV($P(Y,U,2)),1:"N/A")
- . D CHKP^IBNCPEV Q:IBQ
- . W !?10,"DISPENSING FEE:",$S($L($P(Y,U,1)):$J($P(Y,U,1),0,2),1:"N/A")
- . W ", ADMIN FEE:",$S($L($P(Y,U,5)):$J($P(Y,U,5),0,2),1:"N/A")
- . D CHKP^IBNCPEV Q:IBQ
- . W !?10,"INGREDIENT COST:",$S($L($P(Y,U,6)):$J($P(Y,U,6),0,2),1:"N/A")
- . W ", U&C CHARGE:",$S($L($P(Y,U,7)):$J($P(Y,U,7),0,2),1:"N/A")
- . W ", GROSS AMT DUE:",$S($L($P(Y,U,4)):$J($P(Y,U,4),0,2),1:"N/A")
- . Q
- ;
- Q:IBQ
- ;
- D CHKP^IBNCPEV Q:IBQ
- W !?10,"USER:",$$USR^IBNCPEV(+$P(IBD3,U,10))
- Q
- ;
- UNITDISP(QTY,TYP) ; display type of units
- I 'QTY,TYP="" Q "" ; display nothing if no QTY or TYP
- I TYP="" S TYP=" " ; default if ""
- Q " ("_TYP_")"
- ;
- PLANID(PLID) ; display Pharmacy plan ID and the name
- ; Input: PLID - the external plan ID as found in (366.03,.01). Stored for this report as (366.1412,.303).
- N PLNAME,PLANIEN
- S PLID=$G(PLID),PLNAME=""
- I PLID="" G PLANIDX
- S PLANIEN=+$O(^IBCNR(366.03,"B",PLID,""),-1)
- I 'PLANIEN G PLANIDX
- S PLNAME=$P($G(^IBCNR(366.03,PLANIEN,0)),U,2)
- PLANIDX ;
- Q PLID_" ("_PLNAME_")"
- ;
- ;get Exemption status by name
- ;IBEXMP - exemption (like "AO","EC", etc)
- ;IBNODE - node ^IBCNR(366.14,D0,1,D1,4)
- EXMPFLDS(IBEXMP,IBNODE) ;
- Q:IBEXMP="AO" $P(IBNODE,U,1)
- Q:IBEXMP="CV" $P(IBNODE,U,2)
- Q:IBEXMP="SWA" $P(IBNODE,U,3)
- Q:IBEXMP="IR" $P(IBNODE,U,4)
- Q:IBEXMP="MST" $P(IBNODE,U,5)
- Q:IBEXMP="HNC" $P(IBNODE,U,6)
- Q:IBEXMP="SC" $P(IBNODE,U,7)
- Q:IBEXMP="SHAD" $P(IBNODE,U,8)
- Q ""
- ;returns DFN from file #366.14 by prescription ien of file #50
- GETDFN(IBRX) ;
- N IB1,IB2
- S IB1=+$O(^IBCNR(366.14,"I",IBRX,0))
- I IB1=0 Q 0
- S IB2=+$O(^IBCNR(366.14,"I",IBRX,IB1,0))
- I IB2=0 Q 0
- Q +$P($G(^IBCNR(366.14,IB1,1,IB2,0)),U,3)
- ;
- ;return DRUG name (#50,.01)
- ;IBX1 - ien in file #50
- DRUGNAM(IBX1) ;
- N X
- K ^TMP($J,"IBNCPDP50")
- D DATA^PSS50(IBX1,"","","","","IBNCPDP50")
- S X=$G(^TMP($J,"IBNCPDP50",IBX1,.01))
- K ^TMP($J,"IBNCPDP50")
- Q X
- ;
- DRUGAPI(DRUGIEN,FLDNUM) ;
- ;return a DRUG's field value
- ;input:
- ; DRUGIEN - ien #50
- ; FLDNUM - field number (like .01)
- ;output:
- ; returned value that contains the external value of the specified field
- N IBARR,DIQ,DIC
- S DIQ="IBARR",DIQ(0)="E",DIC=50
- D EN^PSSDI(50,"IB",DIC,.FLDNUM,.DRUGIEN,.DIQ)
- Q $G(IBARR(50,DRUGIEN,FLDNUM,"E"))
- ;
- ;reopen
- REOPEN ;
- D CHKP^IBNCPEV Q:IBQ
- D SUBHDR^IBNCPEV
- ;IB*2.0*516/baa Use HIPAA compliant fields
- I +$P(IBD3,U,3) D CHKP^IBNCPEV Q:IBQ W !?10,"PLAN:",$$GET1^DIQ(355.3,+$P(IBD3,U,3)_",",2.01),", INSURANCE: ",$$GET1^DIQ(355.3,+$P(IBD3,U,3)_",",.01,"E")
- I $L($P(IBD3,U,6))>2 D CHKP^IBNCPEV Q:IBQ W !?10,"REOPEN COMMENTS:",$P(IBD3,U,6)
- D CHKP^IBNCPEV Q:IBQ
- D DISPUSR^IBNCPEV
- Q
- ;
- ;Prompts user to select multiple divisions (BPS PHARMACIES)
- ; in order to filter the report by division(s) or for ALL divisions
- ;
- ;returns composite value:
- ;1st piece
- ; 1 - divisions were selected
- ; 0 - divisions were NOT selected
- ; -1 if up arrow entered or timeout
- ;2nd piece
- ; A-all or D - division(s) in the BPS PHARMACIES file #9002313.56)
- ;
- ;and by reference:
- ;IBPSPHAR (only if the user selects "D") - a local array with iens and names
- ; of BPS PHARMACIES (file #9002313.56) selected by the user
- ; IBPSPHAR(ien of file #9002313.56) = ien of file #9002313.56 ^ name of the BPS PHARMACY
- ;
- MULTIDIV(IBPSPHAR) ;
- N IBDIVCNT,IBANSW,IBRETV
- S IBRETV=$$SELPHARM^BPSUTIL(.IBPSPHAR)
- I IBRETV="^" Q -1 ;exit
- I IBRETV="A" Q "0^A"
- Q "1^D"
- ;
- ;check if ePharmacy division in IB36614 in among those selected by the user
- ;IBDIVS - a local array (by reference) with divisions selected by the user
- ;returns 0 - not among selected divisions, 1 - among them
- CHECKDIV(IB36614,IBDIVS) ;
- I $D(IBDIVS(IB36614)) Q 1
- Q 0
- ;
- ;Compile the string for divisions
- ;input:
- ;IBDVS - division local array by reference
- ;output:
- ; return value with the resulting string
- DISPLDIV(IBDVS) ;
- I ('$D(IBDVS))!($G(IBDVS)="") Q "" ;invalid parameters
- I IBDVS=0 Q "" ;if "all" or single division
- N IBZ,IBCNT,IBDIVSTR
- S IBDIVSTR=""
- S IBZ=0,IBCNT=0
- F S IBZ=$O(IBDVS(IBZ)) Q:+IBZ=0 D
- . I IBCNT>0 S IBDIVSTR=IBDIVSTR_", "
- . S IBCNT=IBCNT+1
- . S IBDIVSTR=IBDIVSTR_$P(IBDVS(IBZ),U,2)
- I $L(IBDIVSTR)'<80 S IBDIVSTR=$E(IBDIVSTR,1,75)_"..."
- Q $$CENTERIT(IBDIVSTR,80)
- ;
- ;Compile the string for title
- ;input:
- ;IBBDT - begin date
- ;IBEDT - end date
- ;IBDTL - summary/detail mode
- ;IBDIVS - division local array by reference
- ;output:
- ; return value with the resulting string
- DISPTITL(IBBDT,IBEDT,IBDTL,IBDIVS) ;
- I ('$D(IBDIVS))!($G(IBDIVS)="")!($G(IBBDT)="")!($G(IBEDT)="")!($G(IBDTL)="") Q "" ;invalid parameters
- N IBTITL
- S IBTITL="BILLING ECME EVENTS ON "_$$DAT^IBNCPEV(IBBDT)
- I IBBDT'=IBEDT S IBTITL=IBTITL_" TO "_$$DAT^IBNCPEV(IBEDT)
- S IBTITL=IBTITL_" ("_$S(IBDTL:"DETAILED",1:"SUMMARY")_") for "
- I IBDIVS'=0 S IBTITL=IBTITL_"SELECTED DIVISIONS:"
- I IBDIVS=0 S IBTITL=IBTITL_$P(IBDIVS(0),U,2)_" DIVISION" I $P(IBDIVS(0),U,2)="ALL" S IBTITL=IBTITL_"S"
- Q $$CENTERIT(IBTITL,80)
- ;
- ;Center the string (add left pads to center the string)
- ;input:
- ;IBSTR - input string
- ;IBMAXLEN - max len
- ;output:
- ; return value with the resulting string
- CENTERIT(IBSTR,IBMAXLEN) ;
- I ($G(IBSTR)="")!(+$G(IBMAXLEN)=0) Q ""
- N IBLEFT,IBSP
- S IBSTR=$E(IBSTR,1,IBMAXLEN)
- S IBLEFT=((IBMAXLEN-$L(IBSTR))/2)\1
- S IBSP=""
- S $P(IBSP," ",IBLEFT+1)=""
- Q IBSP_IBSTR
- ;Get list of indicators that were not answered
- GETNOANS(IBD4) ;
- N IBX,IBT,IBSC,IBEXMPV,IBQ,IBRET
- S IBQ=0,IBRET=""
- F IBX=2:1 S IBT=$P($T(EXEMPT+IBX^IBNCPDP1),";",3),IBSC=$P(IBT,U,2) Q:IBSC="" S IBEXMPV=$$EXMPFLDS^IBNCPEV1(IBSC,IBD4) D:IBEXMPV]""
- . I IBEXMPV=2 S IBRET=IBRET_","_IBSC
- Q $S(IBRET="":"SC",1:$E(IBRET,2,99))
- ;IBNCPEV1
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBNCPEV1 11410 printed Feb 18, 2025@23:51:29 Page 2
- IBNCPEV1 ;DALOI/SS - NCPDP BILLING EVENTS REPORT ;21-MAR-2006
- +1 ;;2.0;INTEGRATED BILLING;**342,339,363,411,435,452,516,550,647**;21-MAR-94;Build 10
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ;IA# 10155 is used to read ^DD(file,field,0) node
- +5 QUIT
- +6 ;
- SETVARS ;
- +1 ;newed in IBNCPEV
- +2 SET (IBECME,IBPAT,IBRX,IBQ,IBSCR,IBPAGE,IBDTL,IBDIVS)=0
- +3 ;date
- +4 FOR
- DO DATE^IBNCPDPE
- if IBQ
- QUIT
- if $$TESTDATA^IBNCPDPE
- QUIT
- +5 if IBQ
- QUIT
- +6 NEW IBMLTDV
- SET IBMLTDV=$$MULTPHRM^BPSUTIL()
- +7 IF +IBMLTDV=1
- SET IBDIVS=+$$MULTIDIV(.IBDIVS)
- if IBDIVS=0
- SET IBDIVS(0)="0^ALL"
- IF IBDIVS=-1
- SET IBQ=1
- QUIT
- +8 IF +IBMLTDV=0
- SET IBDIVS=0
- SET IBDIVS(0)="0^"_$PIECE(IBMLTDV,U,2)
- +9 DO MODE^IBNCPDPE
- if IBQ
- QUIT
- +10 DO DEVICE^IBNCPDPE
- if IBQ
- QUIT
- +11 QUIT
- +12 ;
- +13 ;/**
- GETRX(IBECMENO,IBST,IBEND,IBECME) ; get ien of file 52 from #366.14
- +1 ; input -
- +2 ; IBECMENO = ECME # input from the user (with or without leading zeros)
- +3 ; IBST = start date (FM format)
- +4 ; IBEND = end date (FM format)
- +5 ; output - function value: returns internal entry number of file #52 for the earliest date within the date range
- +6 ; IBECME - output variable pass by reference. Returns the external version of the ECME# with leading zeros
- +7 ;
- +8 ; This subroutine is called when the user enters an ECME# as part of the search criteria
- +9 ;
- +10 NEW IBDATE,IBNO,IBIEN,IBFOUND,IBRXIEN,ECMELEN,IBRXIEN
- +11 SET (IBFOUND,IBRXIEN)=0
- +12 FOR ECMELEN=12,7
- Begin DoDot:1
- +13 IF $LENGTH(+IBECMENO)>ECMELEN
- QUIT
- +14 ; build ECME# with leading zeros to proper length
- SET IBECMENO=$$RJ^XLFSTR(+IBECMENO,ECMELEN,0)
- +15 SET IBDATE=+$ORDER(^IBCNR(366.14,"E",IBECMENO,IBST-1))
- if 'IBDATE
- QUIT
- +16 IF IBDATE>IBEND
- QUIT
- +17 SET IBNO=+$ORDER(^IBCNR(366.14,"E",IBECMENO,IBDATE,0))
- if 'IBNO
- QUIT
- +18 SET IBIEN=+$ORDER(^IBCNR(366.14,"B",IBDATE,0))
- if 'IBIEN
- QUIT
- +19 SET IBRXIEN=+$PIECE($GET(^IBCNR(366.14,IBIEN,1,IBNO,2)),U,1)
- +20 IF IBRXIEN
- SET IBFOUND=1
- SET IBECME=IBECMENO
- QUIT
- +21 QUIT
- End DoDot:1
- if IBFOUND
- QUIT
- +22 QUIT IBRXIEN
- +23 ;
- DSTAT(IBD0,IBD2,IBD3,IBD4,IBINS,IBD7) ; finish event/IB Billing Determination event
- +1 ;input:
- +2 ;IBD0 - node ^IBCNR(366.14,D0,1,D1,0)
- +3 ;IBD2 - node ^IBCNR(366.14,D0,1,D1,2)
- +4 ;IBD3 - node ^IBCNR(366.14,D0,1,D1,3)
- +5 ;IBD4 - node ^IBCNR(366.14,D0,1,D1,4)
- +6 ;IBINS - multiple of ^IBCNR(366.14,D0,1,D1,5)
- +7 ;IBD7 - node ^IBCNR(366.14,D0,1,D1,7)
- +8 ;
- +9 NEW IBX,IBT,IBSC,IB1ST,IBNXT,IBEXMPV
- +10 SET IB1ST=1
- +11 DO CHKP^IBNCPEV
- if IBQ
- QUIT
- +12 ;
- +13 WRITE !?10,"ELIGIBILITY: "
- +14 ; esg - 5/1/11 - IB*2*452
- WRITE $$EXTERNAL^DILFD(366.141,7.05,,$PIECE(IBD7,U,5))
- +15 ;
- +16 WRITE !?10,"EI/SC INDICATORS: "
- +17 FOR IBX=2:1
- SET IBT=$PIECE($TEXT(EXEMPT+IBX^IBNCPDP1),";",3)
- SET IBSC=$PIECE(IBT,U,2)
- if IBSC=""
- QUIT
- SET IBEXMPV=$$EXMPFLDS(IBSC,IBD4)
- if IBEXMPV]""
- Begin DoDot:1
- +18 IF IBEXMPV=3
- WRITE "overridden by the user"
- QUIT
- +19 IF 'IB1ST
- WRITE ","
- IF $X>70
- DO CHKP^IBNCPEV
- if IBQ
- QUIT
- WRITE !?10
- SET IB1ST=1
- +20 WRITE " ",IBSC,":",$SELECT(IBEXMPV=1:"Yes",IBEXMPV=0:"No",IBEXMPV=2:"No Answer",1:"?")
- SET IB1ST=0
- End DoDot:1
- if IBQ!(IBEXMPV=3)
- QUIT
- +21 if IBQ
- QUIT
- +22 ;
- +23 IF $PIECE(IBD4,U,9)
- WRITE !?10,"ACTIVE DUTY: Yes"
- +24 ;
- +25 IF $PIECE(IBD2,U,4)
- DO CHKP^IBNCPEV
- if IBQ
- QUIT
- WRITE !?10,"DRUG:",$$DRUGNAM(+$PIECE(IBD2,U,4))
- +26 ;
- +27 ; esg - 9/29/15 - IB*2*550 - Display Drug file ECME billable fields
- +28 IF ($PIECE(IBD7,U,6)=0)!($PIECE(IBD7,U,7)=0)!($PIECE(IBD7,U,8)=0)
- Begin DoDot:1
- +29 ; billable result - no display
- IF $PIECE(IBD0,U,7)
- QUIT
- +30 ; veteran, drug billable - no display
- IF $PIECE(IBD7,U,5)="V"
- IF $PIECE(IBD7,U,6)
- QUIT
- +31 ; tricare, drug billable - no display
- IF $PIECE(IBD7,U,5)="T"
- IF $PIECE(IBD7,U,6)
- IF $PIECE(IBD7,U,7)
- QUIT
- +32 ; champva, drug billable - no display
- IF $PIECE(IBD7,U,5)="C"
- IF $PIECE(IBD7,U,6)
- IF $PIECE(IBD7,U,8)
- QUIT
- +33 DO CHKP^IBNCPEV
- if IBQ
- QUIT
- +34 WRITE !?10,"DRUG ECME BILLABLE: ",$SELECT($PIECE(IBD7,U,6):"Yes",1:"No")
- +35 IF $PIECE(IBD7,U,5)="T"
- DO CHKP^IBNCPEV
- if IBQ
- QUIT
- WRITE !?10,"DRUG ECME BILLABLE (TRICARE): ",$SELECT($PIECE(IBD7,U,7):"Yes",1:"No")
- +36 IF $PIECE(IBD7,U,5)="C"
- DO CHKP^IBNCPEV
- if IBQ
- QUIT
- WRITE !?10,"DRUG ECME BILLABLE (CHAMPVA): ",$SELECT($PIECE(IBD7,U,8):"Yes",1:"No")
- +37 QUIT
- End DoDot:1
- if IBQ
- QUIT
- +38 ;
- +39 ; esg - 9/29/15 - IB*2*550 - Display sensitive diagnosis drug if not billable and the message contains "ROI"
- +40 IF $PIECE(IBD7,U,9)
- IF '$PIECE(IBD0,U,7)
- IF $PIECE(IBD0,U,8)["ROI"
- Begin DoDot:1
- +41 DO CHKP^IBNCPEV
- if IBQ
- QUIT
- +42 WRITE !?10,"SENSITIVE DIAGNOSIS DRUG: Yes"
- +43 QUIT
- End DoDot:1
- if IBQ
- QUIT
- +44 ;
- +45 DO CHKP^IBNCPEV
- if IBQ
- QUIT
- +46 WRITE !?10,"NDC:",$SELECT($PIECE(IBD2,U,5):$PIECE(IBD2,U,5),1:"No")
- +47 WRITE ", NCPDP QTY:",$SELECT($PIECE(IBD2,U,14):$PIECE(IBD2,U,14),1:"No")
- +48 ; display NCPDP unit type
- WRITE $$UNITDISP($PIECE(IBD2,U,14),$PIECE(IBD2,U,15))
- +49 ;
- +50 DO CHKP^IBNCPEV
- if IBQ
- QUIT
- +51 WRITE !?10,"BILLED QTY:",$SELECT($PIECE(IBD2,U,8):$PIECE(IBD2,U,8),1:"No")
- +52 ; display billing unit type
- WRITE $$UNITDISP($PIECE(IBD2,U,8),$PIECE(IBD2,U,13))
- +53 WRITE ", UNIT COST:",$SELECT($PIECE(IBD3,U,4):$PIECE(IBD3,U,4),1:"No")
- +54 IF $PIECE(IBD2,U,10)]""
- WRITE ", DEA:",$PIECE(IBD2,U,10)
- +55 ;
- +56 ; display insurance subfile data
- +57 SET IBX=0
- SET IBNXT=0
- FOR
- SET IBX=$ORDER(IBINS(IBX))
- if 'IBX
- QUIT
- Begin DoDot:1
- +58 NEW Y,Y3,PLANIEN
- +59 SET Y=$GET(IBINS(IBX,0))
- +60 SET PLANIEN=+$PIECE(Y,U,2)
- IF 'PLANIEN
- WRITE "@@@@"
- QUIT
- +61 IF IBNXT
- DO CHKP^IBNCPEV
- if IBQ
- QUIT
- WRITE !?10,"-----------"
- +62 DO CHKP^IBNCPEV
- if IBQ
- QUIT
- WRITE !?10
- +63 ;
- +64 ;IB*2.0*516/baa - Use HIPAA compliant fields
- +65 WRITE "PLAN:",$$GET1^DIQ(355.3,PLANIEN_",",2.01)
- +66 WRITE ", INSURANCE:",$$GET1^DIQ(355.3,PLANIEN_",",.01,"E")
- +67 IF +IBD7>0
- WRITE ", COB:",$SELECT(+IBD7=2:"S",1:"P")
- +68 ;
- +69 ; display pharmacy plan ID and name
- +70 DO CHKP^IBNCPEV
- if IBQ
- QUIT
- +71 SET Y3=$GET(IBINS(IBX,3))
- +72 WRITE !?10,"PHARMACY PLAN:",$SELECT($LENGTH($PIECE(Y3,U,3)):$$PLANID($PIECE(Y3,U,3)),1:"N/A")
- +73 ;
- +74 DO CHKP^IBNCPEV
- if IBQ
- QUIT
- WRITE !?10
- SET IB1ST=1
- +75 IF $PIECE(Y,U,3)]""
- WRITE "BIN:",$PIECE(Y,U,3)
- SET IB1ST=0
- +76 IF $PIECE(Y,U,4)]""
- if 'IB1ST
- WRITE ", "
- WRITE "PCN:",$PIECE(Y,U,4)
- SET IB1ST=0
- +77 IF $PIECE(Y,U,5)]""
- if 'IB1ST
- WRITE ", "
- WRITE "PAYER SHEET B1:",$PIECE(Y,U,5)
- SET IB1ST=0
- +78 ;
- +79 DO CHKP^IBNCPEV
- if IBQ
- QUIT
- WRITE !?10
- SET IB1ST=1
- +80 SET Y=$GET(IBINS(IBX,1))
- +81 IF $PIECE(Y,U,4)]""
- WRITE "PAYER SHEET B2:",$PIECE(Y,U,4)
- SET IB1ST=0
- +82 IF $PIECE(Y,U,5)]""
- if 'IB1ST
- WRITE ", "
- WRITE "PAYER SHEET B3:",$PIECE(Y,U,5)
- +83 ;
- +84 DO CHKP^IBNCPEV
- if IBQ
- QUIT
- +85 SET Y=$GET(IBINS(IBX,2))
- +86 WRITE !?10,"BASIS OF COST DETERM:",$SELECT($LENGTH($PIECE(Y,U,2)):$$BOCD^IBNCPEV($PIECE(Y,U,2)),1:"N/A")
- +87 DO CHKP^IBNCPEV
- if IBQ
- QUIT
- +88 WRITE !?10,"DISPENSING FEE:",$SELECT($LENGTH($PIECE(Y,U,1)):$JUSTIFY($PIECE(Y,U,1),0,2),1:"N/A")
- +89 WRITE ", ADMIN FEE:",$SELECT($LENGTH($PIECE(Y,U,5)):$JUSTIFY($PIECE(Y,U,5),0,2),1:"N/A")
- +90 DO CHKP^IBNCPEV
- if IBQ
- QUIT
- +91 WRITE !?10,"INGREDIENT COST:",$SELECT($LENGTH($PIECE(Y,U,6)):$JUSTIFY($PIECE(Y,U,6),0,2),1:"N/A")
- +92 WRITE ", U&C CHARGE:",$SELECT($LENGTH($PIECE(Y,U,7)):$JUSTIFY($PIECE(Y,U,7),0,2),1:"N/A")
- +93 WRITE ", GROSS AMT DUE:",$SELECT($LENGTH($PIECE(Y,U,4)):$JUSTIFY($PIECE(Y,U,4),0,2),1:"N/A")
- +94 QUIT
- End DoDot:1
- if IBQ
- QUIT
- SET IBNXT=1
- +95 ;
- +96 if IBQ
- QUIT
- +97 ;
- +98 DO CHKP^IBNCPEV
- if IBQ
- QUIT
- +99 WRITE !?10,"USER:",$$USR^IBNCPEV(+$PIECE(IBD3,U,10))
- +100 QUIT
- +101 ;
- UNITDISP(QTY,TYP) ; display type of units
- +1 ; display nothing if no QTY or TYP
- IF 'QTY
- IF TYP=""
- QUIT ""
- +2 ; default if ""
- IF TYP=""
- SET TYP=" "
- +3 QUIT " ("_TYP_")"
- +4 ;
- PLANID(PLID) ; display Pharmacy plan ID and the name
- +1 ; Input: PLID - the external plan ID as found in (366.03,.01). Stored for this report as (366.1412,.303).
- +2 NEW PLNAME,PLANIEN
- +3 SET PLID=$GET(PLID)
- SET PLNAME=""
- +4 IF PLID=""
- GOTO PLANIDX
- +5 SET PLANIEN=+$ORDER(^IBCNR(366.03,"B",PLID,""),-1)
- +6 IF 'PLANIEN
- GOTO PLANIDX
- +7 SET PLNAME=$PIECE($GET(^IBCNR(366.03,PLANIEN,0)),U,2)
- PLANIDX ;
- +1 QUIT PLID_" ("_PLNAME_")"
- +2 ;
- +3 ;get Exemption status by name
- +4 ;IBEXMP - exemption (like "AO","EC", etc)
- +5 ;IBNODE - node ^IBCNR(366.14,D0,1,D1,4)
- EXMPFLDS(IBEXMP,IBNODE) ;
- +1 if IBEXMP="AO"
- QUIT $PIECE(IBNODE,U,1)
- +2 if IBEXMP="CV"
- QUIT $PIECE(IBNODE,U,2)
- +3 if IBEXMP="SWA"
- QUIT $PIECE(IBNODE,U,3)
- +4 if IBEXMP="IR"
- QUIT $PIECE(IBNODE,U,4)
- +5 if IBEXMP="MST"
- QUIT $PIECE(IBNODE,U,5)
- +6 if IBEXMP="HNC"
- QUIT $PIECE(IBNODE,U,6)
- +7 if IBEXMP="SC"
- QUIT $PIECE(IBNODE,U,7)
- +8 if IBEXMP="SHAD"
- QUIT $PIECE(IBNODE,U,8)
- +9 QUIT ""
- +10 ;returns DFN from file #366.14 by prescription ien of file #50
- GETDFN(IBRX) ;
- +1 NEW IB1,IB2
- +2 SET IB1=+$ORDER(^IBCNR(366.14,"I",IBRX,0))
- +3 IF IB1=0
- QUIT 0
- +4 SET IB2=+$ORDER(^IBCNR(366.14,"I",IBRX,IB1,0))
- +5 IF IB2=0
- QUIT 0
- +6 QUIT +$PIECE($GET(^IBCNR(366.14,IB1,1,IB2,0)),U,3)
- +7 ;
- +8 ;return DRUG name (#50,.01)
- +9 ;IBX1 - ien in file #50
- DRUGNAM(IBX1) ;
- +1 NEW X
- +2 KILL ^TMP($JOB,"IBNCPDP50")
- +3 DO DATA^PSS50(IBX1,"","","","","IBNCPDP50")
- +4 SET X=$GET(^TMP($JOB,"IBNCPDP50",IBX1,.01))
- +5 KILL ^TMP($JOB,"IBNCPDP50")
- +6 QUIT X
- +7 ;
- DRUGAPI(DRUGIEN,FLDNUM) ;
- +1 ;return a DRUG's field value
- +2 ;input:
- +3 ; DRUGIEN - ien #50
- +4 ; FLDNUM - field number (like .01)
- +5 ;output:
- +6 ; returned value that contains the external value of the specified field
- +7 NEW IBARR,DIQ,DIC
- +8 SET DIQ="IBARR"
- SET DIQ(0)="E"
- SET DIC=50
- +9 DO EN^PSSDI(50,"IB",DIC,.FLDNUM,.DRUGIEN,.DIQ)
- +10 QUIT $GET(IBARR(50,DRUGIEN,FLDNUM,"E"))
- +11 ;
- +12 ;reopen
- REOPEN ;
- +1 DO CHKP^IBNCPEV
- if IBQ
- QUIT
- +2 DO SUBHDR^IBNCPEV
- +3 ;IB*2.0*516/baa Use HIPAA compliant fields
- +4 IF +$PIECE(IBD3,U,3)
- DO CHKP^IBNCPEV
- if IBQ
- QUIT
- WRITE !?10,"PLAN:",$$GET1^DIQ(355.3,+$PIECE(IBD3,U,3)_",",2.01),", INSURANCE: ",$$GET1^DIQ(355.3,+$PIECE(IBD3,U,3)_",",.01,"E")
- +5 IF $LENGTH($PIECE(IBD3,U,6))>2
- DO CHKP^IBNCPEV
- if IBQ
- QUIT
- WRITE !?10,"REOPEN COMMENTS:",$PIECE(IBD3,U,6)
- +6 DO CHKP^IBNCPEV
- if IBQ
- QUIT
- +7 DO DISPUSR^IBNCPEV
- +8 QUIT
- +9 ;
- +10 ;Prompts user to select multiple divisions (BPS PHARMACIES)
- +11 ; in order to filter the report by division(s) or for ALL divisions
- +12 ;
- +13 ;returns composite value:
- +14 ;1st piece
- +15 ; 1 - divisions were selected
- +16 ; 0 - divisions were NOT selected
- +17 ; -1 if up arrow entered or timeout
- +18 ;2nd piece
- +19 ; A-all or D - division(s) in the BPS PHARMACIES file #9002313.56)
- +20 ;
- +21 ;and by reference:
- +22 ;IBPSPHAR (only if the user selects "D") - a local array with iens and names
- +23 ; of BPS PHARMACIES (file #9002313.56) selected by the user
- +24 ; IBPSPHAR(ien of file #9002313.56) = ien of file #9002313.56 ^ name of the BPS PHARMACY
- +25 ;
- MULTIDIV(IBPSPHAR) ;
- +1 NEW IBDIVCNT,IBANSW,IBRETV
- +2 SET IBRETV=$$SELPHARM^BPSUTIL(.IBPSPHAR)
- +3 ;exit
- IF IBRETV="^"
- QUIT -1
- +4 IF IBRETV="A"
- QUIT "0^A"
- +5 QUIT "1^D"
- +6 ;
- +7 ;check if ePharmacy division in IB36614 in among those selected by the user
- +8 ;IBDIVS - a local array (by reference) with divisions selected by the user
- +9 ;returns 0 - not among selected divisions, 1 - among them
- CHECKDIV(IB36614,IBDIVS) ;
- +1 IF $DATA(IBDIVS(IB36614))
- QUIT 1
- +2 QUIT 0
- +3 ;
- +4 ;Compile the string for divisions
- +5 ;input:
- +6 ;IBDVS - division local array by reference
- +7 ;output:
- +8 ; return value with the resulting string
- DISPLDIV(IBDVS) ;
- +1 ;invalid parameters
- IF ('$DATA(IBDVS))!($GET(IBDVS)="")
- QUIT ""
- +2 ;if "all" or single division
- IF IBDVS=0
- QUIT ""
- +3 NEW IBZ,IBCNT,IBDIVSTR
- +4 SET IBDIVSTR=""
- +5 SET IBZ=0
- SET IBCNT=0
- +6 FOR
- SET IBZ=$ORDER(IBDVS(IBZ))
- if +IBZ=0
- QUIT
- Begin DoDot:1
- +7 IF IBCNT>0
- SET IBDIVSTR=IBDIVSTR_", "
- +8 SET IBCNT=IBCNT+1
- +9 SET IBDIVSTR=IBDIVSTR_$PIECE(IBDVS(IBZ),U,2)
- End DoDot:1
- +10 IF $LENGTH(IBDIVSTR)'<80
- SET IBDIVSTR=$EXTRACT(IBDIVSTR,1,75)_"..."
- +11 QUIT $$CENTERIT(IBDIVSTR,80)
- +12 ;
- +13 ;Compile the string for title
- +14 ;input:
- +15 ;IBBDT - begin date
- +16 ;IBEDT - end date
- +17 ;IBDTL - summary/detail mode
- +18 ;IBDIVS - division local array by reference
- +19 ;output:
- +20 ; return value with the resulting string
- DISPTITL(IBBDT,IBEDT,IBDTL,IBDIVS) ;
- +1 ;invalid parameters
- IF ('$DATA(IBDIVS))!($GET(IBDIVS)="")!($GET(IBBDT)="")!($GET(IBEDT)="")!($GET(IBDTL)="")
- QUIT ""
- +2 NEW IBTITL
- +3 SET IBTITL="BILLING ECME EVENTS ON "_$$DAT^IBNCPEV(IBBDT)
- +4 IF IBBDT'=IBEDT
- SET IBTITL=IBTITL_" TO "_$$DAT^IBNCPEV(IBEDT)
- +5 SET IBTITL=IBTITL_" ("_$SELECT(IBDTL:"DETAILED",1:"SUMMARY")_") for "
- +6 IF IBDIVS'=0
- SET IBTITL=IBTITL_"SELECTED DIVISIONS:"
- +7 IF IBDIVS=0
- SET IBTITL=IBTITL_$PIECE(IBDIVS(0),U,2)_" DIVISION"
- IF $PIECE(IBDIVS(0),U,2)="ALL"
- SET IBTITL=IBTITL_"S"
- +8 QUIT $$CENTERIT(IBTITL,80)
- +9 ;
- +10 ;Center the string (add left pads to center the string)
- +11 ;input:
- +12 ;IBSTR - input string
- +13 ;IBMAXLEN - max len
- +14 ;output:
- +15 ; return value with the resulting string
- CENTERIT(IBSTR,IBMAXLEN) ;
- +1 IF ($GET(IBSTR)="")!(+$GET(IBMAXLEN)=0)
- QUIT ""
- +2 NEW IBLEFT,IBSP
- +3 SET IBSTR=$EXTRACT(IBSTR,1,IBMAXLEN)
- +4 SET IBLEFT=((IBMAXLEN-$LENGTH(IBSTR))/2)\1
- +5 SET IBSP=""
- +6 SET $PIECE(IBSP," ",IBLEFT+1)=""
- +7 QUIT IBSP_IBSTR
- +8 ;Get list of indicators that were not answered
- GETNOANS(IBD4) ;
- +1 NEW IBX,IBT,IBSC,IBEXMPV,IBQ,IBRET
- +2 SET IBQ=0
- SET IBRET=""
- +3 FOR IBX=2:1
- SET IBT=$PIECE($TEXT(EXEMPT+IBX^IBNCPDP1),";",3)
- SET IBSC=$PIECE(IBT,U,2)
- if IBSC=""
- QUIT
- SET IBEXMPV=$$EXMPFLDS^IBNCPEV1(IBSC,IBD4)
- if IBEXMPV]""
- Begin DoDot:1
- +4 IF IBEXMPV=2
- SET IBRET=IBRET_","_IBSC
- End DoDot:1
- +5 QUIT $SELECT(IBRET="":"SC",1:$EXTRACT(IBRET,2,99))
- +6 ;IBNCPEV1