- IBNCPDR2 ;ALB/BDB - ROI MANAGEMENT, ADD ROI ;30-NOV-07
- ;;2.0;INTEGRATED BILLING;**384,550**;21-MAR-94;Build 25
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- ;
- AD ; -- Add tracking entry
- D FULL^VALM1
- N X,Y,DIC,DA,DR,DD,DO,DIR,DIRUT,DTOUT,DUOUT,IBETYP,IBQUIT,IBTDT,VAIN,VAINDT,IBTRN,IBTDTE,IBROIDR
- ;
- L +^IBT(356.25,0):10 I '$T D PAUSE^IBNCPBB("ROI File busy while trying to add a new entry") G ADDQ
- S X=$P($S($D(^IBT(356.25,0)):^(0),1:"^^-1"),"^",3)+1 L -^IBT(356.25,0)
- S DIC="^IBT(356.25,",DIC(0)="L",DLAYGO=356.25
- S DIC("DR")=".02////"_$G(DFN)_";.03;.04;@1;.05;S IBROIDR=X;.06;I (X-IBROIDR)<0 D EN^DDIOL("" ** The ROI expiration date must be on or after the fill date. **"") S Y=""@1"";.07////1;1.01///NOW;1.02////"
- S DIC("DR")=DIC("DR")_DUZ_";1.03///NOW;1.04////"_DUZ_";1.05///NOW;2.01"
- D FILE^DICN
- N IBNCRPR S IBNCRPR=0 I +Y>0 S IBNCRPR=+Y,ZTIO="",ZTRTN="CTCLN^IBNCPDR2",ZTDTH=$H,ZTSAVE("IBNCRPR")="",ZTDESC="IB - Make ROI Pharmacy entries in Claims Tracking billable"
- I IBNCRPR D ^%ZTLOAD K ZTSK,ZTIO,ZTSAVE,ZTDESC,ZTRTN
- D BLD^IBNCPDR
- ADDQ ;
- S VALMBCK="R"
- Q
- ;
- CTCLN ; -- make ROI Pharmacy entries in Claims Tracking billable
- ; tasked job with IBNCRPR defined - IEN file(#356.25)
- ; search claims tracking for NBR of no ROI (or related to ROI)
- ; set ROI flag to "obtained"
- ; if RNB is related to ROI, clear the RNB
- N IBNCR0,DFN,IBNCRD,IBDT,IBTRN,IBEFDT,IBEXDT,IBX,IBZ,IBT,IBPL,IBINS
- N DIC,DIE,DR,DA,X,Y,IBRX
- S IBNCR0=$G(^IBT(356.25,IBNCRPR,0))
- S DFN=$P(IBNCR0,U,2),IBNCRD=$P(IBNCR0,U,3),IBEFDT=$P(IBNCR0,U,5),IBEXDT=$P(IBNCR0,U,6)
- I $P(IBNCR0,U,7)="0" G CTCLNQ ; inactive ROI
- I 'DFN!('IBNCRD)!('IBEFDT)!('IBEXDT) G CTCLNQ
- S IBDT=0 F S IBDT=$O(^IBT(356,"APTY",DFN,4,IBDT)) Q:'IBDT D:IBDT'<IBEFDT&(IBDT'>IBEXDT)
- . S IBTRN=0 F S IBTRN=$O(^IBT(356,"APTY",DFN,4,IBDT,IBTRN)) Q:'IBTRN D
- .. S IBRX=$P(^IBT(356,IBTRN,0),U,8) ; prescription ien
- .. I IBNCRD'=$$FILE^IBRXUTL(IBRX,6) Q ; make sure drug ien's match
- .. S DR=".31////2" ; set CT SPECIAL CONSENT ROI flag to 'obtained'
- .. ;
- .. ; if the current RNB on file for the CT entry contains "ROI" then clear it out (IB*2*550)
- .. I $P($G(^IBE(356.8,+$P($G(^IBT(356,IBTRN,0)),U,19),0)),U,1)["ROI" S DR=DR_";.19///@" ;clean NB reason
- .. S DIE="^IBT(356,",DA=IBTRN D ^DIE
- K IBNCRPR
- ;
- CTCLNQ ;
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBNCPDR2 2382 printed Jan 18, 2025@03:26:03 Page 2
- IBNCPDR2 ;ALB/BDB - ROI MANAGEMENT, ADD ROI ;30-NOV-07
- +1 ;;2.0;INTEGRATED BILLING;**384,550**;21-MAR-94;Build 25
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ;
- AD ; -- Add tracking entry
- +1 DO FULL^VALM1
- +2 NEW X,Y,DIC,DA,DR,DD,DO,DIR,DIRUT,DTOUT,DUOUT,IBETYP,IBQUIT,IBTDT,VAIN,VAINDT,IBTRN,IBTDTE,IBROIDR
- +3 ;
- +4 LOCK +^IBT(356.25,0):10
- IF '$TEST
- DO PAUSE^IBNCPBB("ROI File busy while trying to add a new entry")
- GOTO ADDQ
- +5 SET X=$PIECE($SELECT($DATA(^IBT(356.25,0)):^(0),1:"^^-1"),"^",3)+1
- LOCK -^IBT(356.25,0)
- +6 SET DIC="^IBT(356.25,"
- SET DIC(0)="L"
- SET DLAYGO=356.25
- +7 SET DIC("DR")=".02////"_$GET(DFN)_";.03;.04;@1;.05;S IBROIDR=X;.06;I (X-IBROIDR)<0 D EN^DDIOL("" ** The ROI expiration date must be on or after the fill date. **"") S Y=""@1"";.07////1;1.01///NOW;1.02////"
- +8 SET DIC("DR")=DIC("DR")_DUZ_";1.03///NOW;1.04////"_DUZ_";1.05///NOW;2.01"
- +9 DO FILE^DICN
- +10 NEW IBNCRPR
- SET IBNCRPR=0
- IF +Y>0
- SET IBNCRPR=+Y
- SET ZTIO=""
- SET ZTRTN="CTCLN^IBNCPDR2"
- SET ZTDTH=$HOROLOG
- SET ZTSAVE("IBNCRPR")=""
- SET ZTDESC="IB - Make ROI Pharmacy entries in Claims Tracking billable"
- +11 IF IBNCRPR
- DO ^%ZTLOAD
- KILL ZTSK,ZTIO,ZTSAVE,ZTDESC,ZTRTN
- +12 DO BLD^IBNCPDR
- ADDQ ;
- +1 SET VALMBCK="R"
- +2 QUIT
- +3 ;
- CTCLN ; -- make ROI Pharmacy entries in Claims Tracking billable
- +1 ; tasked job with IBNCRPR defined - IEN file(#356.25)
- +2 ; search claims tracking for NBR of no ROI (or related to ROI)
- +3 ; set ROI flag to "obtained"
- +4 ; if RNB is related to ROI, clear the RNB
- +5 NEW IBNCR0,DFN,IBNCRD,IBDT,IBTRN,IBEFDT,IBEXDT,IBX,IBZ,IBT,IBPL,IBINS
- +6 NEW DIC,DIE,DR,DA,X,Y,IBRX
- +7 SET IBNCR0=$GET(^IBT(356.25,IBNCRPR,0))
- +8 SET DFN=$PIECE(IBNCR0,U,2)
- SET IBNCRD=$PIECE(IBNCR0,U,3)
- SET IBEFDT=$PIECE(IBNCR0,U,5)
- SET IBEXDT=$PIECE(IBNCR0,U,6)
- +9 ; inactive ROI
- IF $PIECE(IBNCR0,U,7)="0"
- GOTO CTCLNQ
- +10 IF 'DFN!('IBNCRD)!('IBEFDT)!('IBEXDT)
- GOTO CTCLNQ
- +11 SET IBDT=0
- FOR
- SET IBDT=$ORDER(^IBT(356,"APTY",DFN,4,IBDT))
- if 'IBDT
- QUIT
- if IBDT'<IBEFDT&(IBDT'>IBEXDT)
- Begin DoDot:1
- +12 SET IBTRN=0
- FOR
- SET IBTRN=$ORDER(^IBT(356,"APTY",DFN,4,IBDT,IBTRN))
- if 'IBTRN
- QUIT
- Begin DoDot:2
- +13 ; prescription ien
- SET IBRX=$PIECE(^IBT(356,IBTRN,0),U,8)
- +14 ; make sure drug ien's match
- IF IBNCRD'=$$FILE^IBRXUTL(IBRX,6)
- QUIT
- +15 ; set CT SPECIAL CONSENT ROI flag to 'obtained'
- SET DR=".31////2"
- +16 ;
- +17 ; if the current RNB on file for the CT entry contains "ROI" then clear it out (IB*2*550)
- +18 ;clean NB reason
- IF $PIECE($GET(^IBE(356.8,+$PIECE($GET(^IBT(356,IBTRN,0)),U,19),0)),U,1)["ROI"
- SET DR=DR_";.19///@"
- +19 SET DIE="^IBT(356,"
- SET DA=IBTRN
- DO ^DIE
- End DoDot:2
- End DoDot:1
- +20 KILL IBNCRPR
- +21 ;
- CTCLNQ ;
- +1 ;