IBNCPDPE ;DALOI/AAT - NCPDP BILLING EVENTS REPORT ;3/6/08 16:18
;;2.0;INTEGRATED BILLING;**276,342,347,363,384,435**;21-MAR-94;Build 27
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; Reference to $$MULTPHRM^BPSUTIL supported by IA# 4146
; Reference to DIC^PSODI supported by IA# 4858
;
DATE ;
S (IBBDT,IBEDT)=DT
S %DT="AEX"
S %DT("A")="START WITH DATE: ",%DT("B")="TODAY"
D ^%DT K %DT
I Y<0 S IBQ=1 Q
S IBBDT=+Y
S %DT="AEX"
S %DT("A")="GO TO DATE: ",%DT("B")="TODAY"
D ^%DT K %DT
I Y<0 S IBQ=1 Q
S IBEDT=+Y
Q
;
MODE ;
N DIR,DIC,DIRUT,DUOUT,PSOFILE
S (IBM1,IBM2,IBM3)="A"
S DIR(0)="S^P:SINGLE PATIENT;R:SINGLE RX;E:SINGLE ECME #;A:ALL ACTIVITY"
S DIR("A")="SINGLE (P)ATIENT, SINGLE (R)X, SINGLE (E)CME #, (A)LL ACTIVITY"
S DIR("B")="ALL"
D ^DIR K DIR I $D(DIRUT) S IBQ=1 Q
S IBM1=Y
I IBM1="P" S DIC="^DPT(",DIC(0)="AEQMN" D ^DIC Q:$D(DUOUT) S IBPAT=$S(Y>0:+Y,1:0) I 'IBPAT W " ALL" S IBM1="A"
I IBM1="R" S PSOFILE=52,DIC="^PSRX(",DIC(0)="AEQMN" D DIC^PSODI(PSOFILE,.DIC) Q:$D(DUOUT) S IBRX=$S(Y>0:+Y,1:0) I 'IBRX W " ALL" S IBM1="A"
K PSODIY
I IBM1="E" S DIR(0)="FO^1:12^I X'?1.12N W !!,""Cannot contain alpha characters"" K X",DIR("A")="Enter ECME #" D ^DIR Q:$D(DUOUT) S IBECME=$S(+Y>0:Y,1:0) I 'IBECME W " ALL" S IBM1="A"
S IBM2="B"
; if "All"
I IBM1="A" D Q:$G(IBQ)
.S DIR(0)="S^E:ECME BILLABLE;N:NON ECME BILLABLE;B:BOTH"
.S DIR("A")="(E)CME BILLABLE;(N)ON ECME BILLABLE;(B)OTH"
.S DIR("B")="BOTH"
.D ^DIR K DIR I $D(DIRUT) S IBQ=1 Q
.S IBM2=Y
;
;Mail/Window/CMOP?
S DIR(0)="S^M:MAIL;W:WINDOW;C:CMOP;A:ALL"
S DIR("A")="(M)AIL, (W)INDOW, (C)CMOP, (A)LL"
S DIR("B")="ALL"
D ^DIR K DIR I $D(DIRUT) S IBQ=1 Q
S IBM3=Y
;
S DIR(0)="S^S:SUMMARY REPORT;D:DETAILED REPORT"
S DIR("A")="(S)UMMARY REPORT, (D)ETAILED REPORT"
S DIR("B")="SUMMARY REPORT"
D ^DIR K DIR I $D(DIRUT) S IBQ=1 Q
S IBDTL=($E(Y)="D")
Q
;
TESTDATA() ;
N Y
S Y=$$HAVEDATA()
I 'Y W !!,"No data found in the specified period.",!
Q Y
;
HAVEDATA() ;
N Z
I $D(^IBCNR(366.14,"B",IBBDT)) Q 1
S Z=+$O(^IBCNR(366.14,"B",IBBDT))
I Z=0 Q 0
I Z>IBEDT Q 0
Q 1
;
DEVICE ;
N DIR,DIRUT,POP,ZTRTN,ZTIO,ZTSAVE,ZTDESC,%ZIS,ZTSK
S %ZIS="QM"
W ! D ^%ZIS
I POP S IBQ=1 Q
S IBSCR=$S($E($G(IOST),1,2)="C-":1,1:0)
;
I $D(IO("Q")) D S IBQ=1
. S ZTRTN="START^IBNCPEV"
. S ZTIO=ION
. S ZTSAVE("IB*")=""
. S ZTDESC="IB ECME BILLING EVENTS REPORT"
. D ^%ZTLOAD
. W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
. D HOME^%ZIS
U IO
Q
;------ added for the User screen --------
;User Screen Entry point (to call from ECME User Screen)
;IBMODE:
; P-patient
; R-Rx
;IBVAL - patient DFN or RX ien (#52)
;
USRSCREN(IBMODE,IBVAL) ;
N IBPAT,IBRX,IBBDT,IBEDT,Y,IBM1,IBM2,IBM3,IBQ,IBSCR,IBPAGE,IBDTL,IBDIVS
S (IBPAT,IBRX,IBQ,IBSCR,IBPAGE,IBDTL,IBDIVS)=0
S IBM1=IBMODE
I IBM1="P" S IBPAT=+IBVAL
I IBM1="R" S IBRX=+IBVAL
;date
F D DATE Q:IBQ Q:$$TESTDATA
Q:IBQ
N IBMLTDV S IBMLTDV=$$MULTPHRM^BPSUTIL()
I +IBMLTDV=1 S IBDIVS=+$$MULTIDIV^IBNCPEV1(.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 MODE2 Q:IBQ
D DEVICE Q:IBQ
D START^IBNCPEV
D ^%ZISC
I IBQ W !,"Cancelled"
Q
;
MODE2 ;
N DIR,DIC,DIRUT,DUOUT
S (IBM1,IBM2,IBM3)="A"
S IBM2="B"
;
;Mail/Window/CMOP?
S DIR(0)="S^M:MAIL;W:WINDOW;C:CMOP;A:ALL"
S DIR("A")="(M)AIL, (W)INDOW, (C)CMOP, (A)LL"
S DIR("B")="ALL"
D ^DIR K DIR I $D(DIRUT) S IBQ=1 Q
S IBM3=Y
;
S DIR(0)="S^S:SUMMARY REPORT;D:DETAILED REPORT"
S DIR("A")="(S)UMMARY REPORT, (D)ETAILED REPORT"
S DIR("B")="SUMMARY REPORT"
D ^DIR K DIR I $D(DIRUT) S IBQ=1 Q
S IBDTL=($E(Y)="D")
Q
;IBNCPDPE
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBNCPDPE 3802 printed Sep 23, 2025@20:01:03 Page 2
IBNCPDPE ;DALOI/AAT - NCPDP BILLING EVENTS REPORT ;3/6/08 16:18
+1 ;;2.0;INTEGRATED BILLING;**276,342,347,363,384,435**;21-MAR-94;Build 27
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; Reference to $$MULTPHRM^BPSUTIL supported by IA# 4146
+5 ; Reference to DIC^PSODI supported by IA# 4858
+6 ;
DATE ;
+1 SET (IBBDT,IBEDT)=DT
+2 SET %DT="AEX"
+3 SET %DT("A")="START WITH DATE: "
SET %DT("B")="TODAY"
+4 DO ^%DT
KILL %DT
+5 IF Y<0
SET IBQ=1
QUIT
+6 SET IBBDT=+Y
+7 SET %DT="AEX"
+8 SET %DT("A")="GO TO DATE: "
SET %DT("B")="TODAY"
+9 DO ^%DT
KILL %DT
+10 IF Y<0
SET IBQ=1
QUIT
+11 SET IBEDT=+Y
+12 QUIT
+13 ;
MODE ;
+1 NEW DIR,DIC,DIRUT,DUOUT,PSOFILE
+2 SET (IBM1,IBM2,IBM3)="A"
+3 SET DIR(0)="S^P:SINGLE PATIENT;R:SINGLE RX;E:SINGLE ECME #;A:ALL ACTIVITY"
+4 SET DIR("A")="SINGLE (P)ATIENT, SINGLE (R)X, SINGLE (E)CME #, (A)LL ACTIVITY"
+5 SET DIR("B")="ALL"
+6 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET IBQ=1
QUIT
+7 SET IBM1=Y
+8 IF IBM1="P"
SET DIC="^DPT("
SET DIC(0)="AEQMN"
DO ^DIC
if $DATA(DUOUT)
QUIT
SET IBPAT=$SELECT(Y>0:+Y,1:0)
IF 'IBPAT
WRITE " ALL"
SET IBM1="A"
+9 IF IBM1="R"
SET PSOFILE=52
SET DIC="^PSRX("
SET DIC(0)="AEQMN"
DO DIC^PSODI(PSOFILE,.DIC)
if $DATA(DUOUT)
QUIT
SET IBRX=$SELECT(Y>0:+Y,1:0)
IF 'IBRX
WRITE " ALL"
SET IBM1="A"
+10 KILL PSODIY
+11 IF IBM1="E"
SET DIR(0)="FO^1:12^I X'?1.12N W !!,""Cannot contain alpha characters"" K X"
SET DIR("A")="Enter ECME #"
DO ^DIR
if $DATA(DUOUT)
QUIT
SET IBECME=$SELECT(+Y>0:Y,1:0)
IF 'IBECME
WRITE " ALL"
SET IBM1="A"
+12 SET IBM2="B"
+13 ; if "All"
+14 IF IBM1="A"
Begin DoDot:1
+15 SET DIR(0)="S^E:ECME BILLABLE;N:NON ECME BILLABLE;B:BOTH"
+16 SET DIR("A")="(E)CME BILLABLE;(N)ON ECME BILLABLE;(B)OTH"
+17 SET DIR("B")="BOTH"
+18 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET IBQ=1
QUIT
+19 SET IBM2=Y
End DoDot:1
if $GET(IBQ)
QUIT
+20 ;
+21 ;Mail/Window/CMOP?
+22 SET DIR(0)="S^M:MAIL;W:WINDOW;C:CMOP;A:ALL"
+23 SET DIR("A")="(M)AIL, (W)INDOW, (C)CMOP, (A)LL"
+24 SET DIR("B")="ALL"
+25 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET IBQ=1
QUIT
+26 SET IBM3=Y
+27 ;
+28 SET DIR(0)="S^S:SUMMARY REPORT;D:DETAILED REPORT"
+29 SET DIR("A")="(S)UMMARY REPORT, (D)ETAILED REPORT"
+30 SET DIR("B")="SUMMARY REPORT"
+31 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET IBQ=1
QUIT
+32 SET IBDTL=($EXTRACT(Y)="D")
+33 QUIT
+34 ;
TESTDATA() ;
+1 NEW Y
+2 SET Y=$$HAVEDATA()
+3 IF 'Y
WRITE !!,"No data found in the specified period.",!
+4 QUIT Y
+5 ;
HAVEDATA() ;
+1 NEW Z
+2 IF $DATA(^IBCNR(366.14,"B",IBBDT))
QUIT 1
+3 SET Z=+$ORDER(^IBCNR(366.14,"B",IBBDT))
+4 IF Z=0
QUIT 0
+5 IF Z>IBEDT
QUIT 0
+6 QUIT 1
+7 ;
DEVICE ;
+1 NEW DIR,DIRUT,POP,ZTRTN,ZTIO,ZTSAVE,ZTDESC,%ZIS,ZTSK
+2 SET %ZIS="QM"
+3 WRITE !
DO ^%ZIS
+4 IF POP
SET IBQ=1
QUIT
+5 SET IBSCR=$SELECT($EXTRACT($GET(IOST),1,2)="C-":1,1:0)
+6 ;
+7 IF $DATA(IO("Q"))
Begin DoDot:1
+8 SET ZTRTN="START^IBNCPEV"
+9 SET ZTIO=ION
+10 SET ZTSAVE("IB*")=""
+11 SET ZTDESC="IB ECME BILLING EVENTS REPORT"
+12 DO ^%ZTLOAD
+13 WRITE !,$SELECT($DATA(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
+14 DO HOME^%ZIS
End DoDot:1
SET IBQ=1
+15 USE IO
+16 QUIT
+17 ;------ added for the User screen --------
+18 ;User Screen Entry point (to call from ECME User Screen)
+19 ;IBMODE:
+20 ; P-patient
+21 ; R-Rx
+22 ;IBVAL - patient DFN or RX ien (#52)
+23 ;
USRSCREN(IBMODE,IBVAL) ;
+1 NEW IBPAT,IBRX,IBBDT,IBEDT,Y,IBM1,IBM2,IBM3,IBQ,IBSCR,IBPAGE,IBDTL,IBDIVS
+2 SET (IBPAT,IBRX,IBQ,IBSCR,IBPAGE,IBDTL,IBDIVS)=0
+3 SET IBM1=IBMODE
+4 IF IBM1="P"
SET IBPAT=+IBVAL
+5 IF IBM1="R"
SET IBRX=+IBVAL
+6 ;date
+7 FOR
DO DATE
if IBQ
QUIT
if $$TESTDATA
QUIT
+8 if IBQ
QUIT
+9 NEW IBMLTDV
SET IBMLTDV=$$MULTPHRM^BPSUTIL()
+10 IF +IBMLTDV=1
SET IBDIVS=+$$MULTIDIV^IBNCPEV1(.IBDIVS)
if IBDIVS=0
SET IBDIVS(0)="0^ALL"
IF IBDIVS=-1
SET IBQ=1
QUIT
+11 IF +IBMLTDV=0
SET IBDIVS=0
SET IBDIVS(0)="0^"_$PIECE(IBMLTDV,U,2)
+12 DO MODE2
if IBQ
QUIT
+13 DO DEVICE
if IBQ
QUIT
+14 DO START^IBNCPEV
+15 DO ^%ZISC
+16 IF IBQ
WRITE !,"Cancelled"
+17 QUIT
+18 ;
MODE2 ;
+1 NEW DIR,DIC,DIRUT,DUOUT
+2 SET (IBM1,IBM2,IBM3)="A"
+3 SET IBM2="B"
+4 ;
+5 ;Mail/Window/CMOP?
+6 SET DIR(0)="S^M:MAIL;W:WINDOW;C:CMOP;A:ALL"
+7 SET DIR("A")="(M)AIL, (W)INDOW, (C)CMOP, (A)LL"
+8 SET DIR("B")="ALL"
+9 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET IBQ=1
QUIT
+10 SET IBM3=Y
+11 ;
+12 SET DIR(0)="S^S:SUMMARY REPORT;D:DETAILED REPORT"
+13 SET DIR("A")="(S)UMMARY REPORT, (D)ETAILED REPORT"
+14 SET DIR("B")="SUMMARY REPORT"
+15 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET IBQ=1
QUIT
+16 SET IBDTL=($EXTRACT(Y)="D")
+17 QUIT
+18 ;IBNCPDPE
