- 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 Feb 18, 2025@23:51:13 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