- IBCSC5C ;ALB/ARH - ADD/EDIT PRESCRIPTION FILLS (CONTINUED) ;3/4/94
- ;;2.0;INTEGRATED BILLING;**27,52,130,51,160,260,309,315,339,347,363,381,405,432,461**;21-MAR-94;Build 58
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- ;
- DEFAULT(IFN,IBRX) ; add default DX and CPT to a prescription bill
- ; if one is not in PSO. If there is, use it instead.
- ; IFN = ien of bill entry
- N IBX,IBPAR1,IBDX,IBCPT,IBDT,IBBIL,IBDXIFN,IBCPTIFN,IBY,IB52,IBC,PDFN,LIST,NODE
- S IBDXIFN=0
- S IBPAR1=$G(^IBE(350.9,1,1)),IBCPT=$P(IBPAR1,U,30)
- S IBDX=$P(IBPAR1,U,29) I $$ICD9SYS^IBACSV($$BDATE^IBACSV(IFN))=30 S IBDX=$P($G(^IBE(350.9,1,7)),U,5)
- S IBBIL=$G(^DGCR(399,+$G(IFN),0)) Q:IBBIL=""
- S IBX=$S($G(IBRX):$P($G(^DGCR(399,IFN,"RC",+IBRX,0)),U,11),1:$O(^IBA(362.4,"C",IFN,0))) Q:'IBX
- S IB52=+$P($G(^IBA(362.4,IBX,0)),"^",5),IBY=0 Q:IB52=0
- S PDFN=$$FILE^IBRXUTL(IB52,2)
- S LIST="IBCSC5CARR"
- S NODE="ICD"
- D RX^PSO52API(PDFN,LIST,IB52,,NODE,,)
- I ^TMP($J,LIST,PDFN,IB52,"ICD",0)>0 D
- .S IBY=0 F S IBY=$O(^TMP($J,LIST,PDFN,IB52,"ICD",IBY)) Q:IBY'>0 D
- ..S IBDX(IBY)=$$ICD^IBRXUTL1(PDFN,IB52,IBY,LIST)
- ..I 'IBDX(IBY) K IBDX(IBY)
- K ^TMP($J,LIST)
- I 'IBDX,'IBCPT,$D(IBDX)<10 Q
- S IBDT=$P($G(^IBA(362.4,+IBX,0)),U,3) Q:'IBDT
- ; add dx associated with rx if they are there.
- I $D(IBDX)>9 S (IBC,IBDX,IBY)=0 F S IBY=$O(IBDX(IBY)) Q:'IBY D
- . I $D(^IBA(362.3,"AIFN"_IFN,+IBDX(IBY))) Q
- . S IBC=IBC+1
- . S DIC="^IBA(362.3,",DIC(0)="L",DIC("DR")=".02////"_IFN_";.03////"_IBC,X=+IBDX(IBY),DLAYGO=362.3
- . K DD,DO D FILE^DICN K DIC,DA,DR,DD,DO,DLAYGO
- . S IBDXIFN(IBC)=+Y
- ; add default dx if none found on actual rx.
- I +IBDX,'$D(^IBA(362.3,"AIFN"_IFN,+IBDX)) S DIC="^IBA(362.3,",DIC(0)="L",DIC("DR")=".02////"_IFN,X=IBDX,DLAYGO=362.3 K DD,DO D FILE^DICN K DIC,DA,DR,DD,DO,DLAYGO S IBDXIFN=+Y
- I +IBCPT D ;Check if the procedure is already present for the Rx
- . N Z,Z0,DUP
- . S (DUP,Z)=0 F S Z=$O(^DGCR(399,IFN,"RC",Z)) Q:'Z S Z0=$G(^(Z,0)) D Q:DUP
- .. I $P(Z0,U,10)=3,$P(Z0,U,15),$P(Z0,U,11)=IBX S DUP=1
- . Q:DUP
- . I $P($G(^DGCR(399,IFN,0)),U,9)="" S DIE="^DGCR(399,",DA=IFN,DR=".09////5" D ^DIE K DIE,DIC,DA,DR
- . I '$D(^DGCR(399,IFN,"CP",0)) S DIC("P")=$$GETSPEC^IBEFUNC(399,304)
- . S DLAYGO=399,DIC("DR")="1////"_IBDT D
- . . I +IBDXIFN>0 S DIC("DR")=DIC("DR")_";10////"_IBDXIFN Q
- . . I $D(IBDXIFN)>9 F IBY=1:1:4 I $D(IBDXIFN(IBY)) S DIC("DR")=DIC("DR")_";"_(IBY+9)_"////"_IBDXIFN(IBY)
- . S DIC="^DGCR(399,"_IFN_",""CP"",",DIC(0)="L",DA(1)=IFN,X=IBCPT_";ICPT(" K DD,DO D FILE^DICN K DIC,DA,DD,DO,DR,DLAYGO
- . I +Y D
- .. N Z,IBZ
- .. S IBZ=+Y,Z=$S($G(IBREV):IBREV,1:$$FINDREV^IBCSC5A(IFN,3,+IBX))
- .. I Z S DR=".15////"_IBZ_";.06////"_IBCPT,DA=+Z,DA(1)=IFN,DIE="^DGCR(399,"_DA(1)_",""RC""," D ^DIE
- Q
- ;
- RXDISP(DFN,DT1,DT2,ARRAY,POARR,RXARR,IBRXALL,NODISP) ; display all rx fills for a patient and date range
- ;RXARR (as defined by SET^IBCSC5A) passed by ref. only to check if rx-fill is on the bill, not necessary not changed
- ;returns: ARRAY(RX #, FILL DT) = RX IFN (52) ^ FILL IFN ^ DRUG ^ DAYS SUPPLY ^ QTY ^ NDC ^ ORDER DATE, pass by reference if desired
- ; POARR(CNT)=RX # ^ FILL DT
- N PIFN,RIFN,IBX,IBY,DTE,DTR,RX,IBCNT,IBRX0,IBRX2,IBS,LIST,LIST2 K ARRAY,POARR S POARR=0,NODISP=+$G(NODISP)
- S IBCNT=0,DT1=$G(DT1)-.0001,DT2=$G(DT2) S:'DT2 DT2=9999999 Q:'$G(DFN)
- ;^PS(55,DFN,"P","A",EXPIRATION DATE, RX) is the best xref available for finding patient fills in a date range
- ;if RX expires/cancelled before start of bill then should not be applicable to bill
- S LIST="IBRXDISPARR"
- D PROF^PSO52API(DFN,LIST,DT1)
- S DTE=0 F S DTE=$O(^TMP($J,LIST,"B",DTE)) Q:'DTE D
- . S PIFN=0 F S PIFN=$O(^TMP($J,LIST,"B",DTE,PIFN)) Q:'PIFN D
- .. S IBRX0=$$RXZERO^IBRXUTL(DFN,PIFN),IBRX2=$$RXSEC^IBRXUTL(DFN,PIFN)
- .. ; original fill
- .. I +$G(IBRXALL) S DTR=$P(IBRX2,U,2) I DTR'<DT1,DTR'>DT2 D
- ... D DATA^IBRXUTL(+$P(IBRX0,U,6))
- ... ; add issue date to array so order date can be displayed
- ... ;S ARRAY($P(IBRX0,U,1),+DTR)=PIFN_U_0_U_$P(IBRX0,U,6)_U_$P(IBRX0,U,8)_U_$P(IBRX0,U,7)_U_$$GETNDC^PSONDCUT(PIFN,0)
- ... S ARRAY($P(IBRX0,U,1),+DTR)=PIFN_U_0_U_$P(IBRX0,U,6)_U_$P(IBRX0,U,8)_U_$P(IBRX0,U,7)_U_$$GETNDC^PSONDCUT(PIFN,0)_U_$P(IBRX0,U,13)
- ... K ^TMP($J,"IBDRUG")
- ... Q
- .. ; refills
- .. S LIST2="IBDISPSUB"
- .. S NODE="R"
- .. D RX^PSO52API(DFN,LIST2,PIFN,,NODE,,)
- .. S RIFN=0 F S RIFN=$O(^TMP($J,LIST2,DFN,PIFN,"RF",RIFN)) Q:RIFN'>0 D
- ... S IBY=$$ZEROSUB^IBRXUTL(DFN,PIFN,RIFN) Q:IBY=""
- ... Q:+IBY<DT1!(+IBY>DT2)
- ... D DATA^IBRXUTL(+$P(IBRX0,U,6))
- ... ; add issue date to array so order date can be displayed
- ... ;S ARRAY($P(IBRX0,U,1),+IBY)=PIFN_U_RIFN_U_$P(IBRX0,U,6)_U_$P(IBRX0,U,8)_U_$P(IBY,U,4)_U_$$GETNDC^PSONDCUT(PIFN,RIFN)
- ... S ARRAY($P(IBRX0,U,1),+IBY)=PIFN_U_RIFN_U_$P(IBRX0,U,6)_U_$P(IBRX0,U,8)_U_$P(IBY,U,4)_U_$$GETNDC^PSONDCUT(PIFN,RIFN)_U_$P(IBRX0,U,13)
- ... K ^TMP($J,"IBDRUG")
- ... Q
- .. K ^TMP($J,LIST2)
- K ^TMP($J,LIST)
- ;
- S IBX="",IBS=0 F S IBX=$O(ARRAY(IBX)) Q:IBX="" S IBY=0 F S IBY=$O(ARRAY(IBX,IBY)) Q:'IBY D
- . S IBCNT=IBCNT+1,POARR(IBCNT)=$P(IBX,U,1)_"^"_+IBY,POARR=IBCNT I $D(RXARR(IBX,IBY)) S IBS=IBS+1
- S $P(POARR,U,2)=IBCNT-IBS
- ;
- Q:+NODISP
- W @IOF,?33,"PRESCRIPTIONS IN DATE RANGE",!,"===============================================================================",!
- S IBCNT=0 F S IBCNT=$O(POARR(IBCNT)) Q:IBCNT="" S RX=$P(POARR(IBCNT),U,1),DTR=$P(POARR(IBCNT),U,2) I RX'="",DTR'="" D
- . S IBS=$$RXSTAT^IBCU1($P(ARRAY(RX,DTR),U,3),$P(ARRAY(RX,DTR),U,1),DTR)
- . S IBY="" I $D(RXARR(RX,+DTR)) S IBY="*"
- . D ZERO^IBRXUTL(+$P(ARRAY(RX,DTR),U,3))
- . W !,$J(IBCNT,2),")",?5,IBY,?6,RX,?19,$E($G(^TMP($J,"IBDRUG",+$P(ARRAY(RX,DTR),U,3),.01)),1,25),?46,$$DATE(+DTR),?56,$P(IBS,U,1),?61,$P(IBS,U,2),?69,$P(IBS,U,3),?75,$$EXEMPT(+ARRAY(RX,DTR))
- . S IBY=$$RXDUP^IBCU3(RX,DTR,IBIFN) I +IBY W ?73,$P($G(^DGCR(399,+IBY,0)),U,1)
- . K ^TMP($J,"IBDRUG")
- Q
- DATE(X) Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
- ;
- NEWRX(IBX) ;
- Q:'$G(IBX) N X,Y K IBLIST W !
- NEWRX1 S DIR("?")="Enter the number preceding the RX Fills you want added to the bill. "_$$HTEXT
- S DIR("A")="SELECT NEW RX FILLS TO ADD THE BILL"
- S DIR(0)="LO^1:"_+IBX D ^DIR K DIR G:'Y!$D(DIRUT) NEWRXE
- S IBLIST=Y
- ;
- S DIR("A")="YOU HAVE SELECTED "_IBLIST_" TO BE ADDED TO THE BILL IS THIS CORRECT",DIR("B")="YES"
- S DIR(0)="YO" D ^DIR K DIR I $D(DIRUT) K IBLIST G NEWRXE
- I 'Y K IBLIST G NEWRX1
- NEWRXE Q
- ;
- ADDNEW(IBIFN,LIST,IBPR,IBPRO) ;
- Q:'LIST N IBI,IBX,IBRX,IBDT,IBQ,IBY,IBPIFN,IBZ
- F IBI=1:1 S IBX=$P(LIST,",",IBI) Q:'IBX I $D(IBPRO(IBX)) D
- . S IBRX=$P(IBPRO(IBX),U,1),IBDT=$P(IBPRO(IBX),U,2) Q:IBRX=""
- . S IBQ=0,IBY=$G(IBPR(IBRX,+IBDT)) Q:'IBY
- . S IBPIFN=0 F S IBPIFN=$O(^IBA(362.4,"AIFN"_IBIFN,IBRX,IBPIFN)) Q:'IBPIFN I $P($G(^IBA(362.4,IBPIFN,0)),U,3)=IBDT S IBQ=1 Q
- . ;I 'IBQ S IBZ=$G(IBPR(IBRX,IBDT)) I $$ADD^IBCSC5A(IBRX,IBIFN,IBDT,$P(IBZ,U,3),$P(IBZ,U,1),$P(IBZ,U,4,6),$P(IBZ,U,2)) W "."
- . ; IB*2.0*432 - include issue date from file 52 to display to user when adding
- . I 'IBQ S IBZ=$G(IBPR(IBRX,IBDT)) I $$ADD^IBCSC5A(IBRX,IBIFN,IBDT,$P(IBZ,U,3),$P(IBZ,U,1),$P(IBZ,U,4,7),$P(IBZ,U,2)) W "."
- Q
- ;
- HTEXT() ;
- N X S X="If an Rx fill has been assigned to another bill it will be displayed in the last column. [ORG=Original Fill, NR=Not Released, RTS=Returned to Stock, OTC=Over-the-Counter, INV=Investigational, SUP=Supply Item]"
- Q X
- ;
- RXLINK(IBIFN,CPIEN) ; Function returns the ien of the Rx rev code the proc
- ; code is linked to or 0 if no link found.
- Q +$O(^DGCR(399,IBIFN,"RC","ACP",+CPIEN,0))
- ;
- EXEMPT(RX) ; Used to look up exemption if any on rx, the return value
- ; will be only the first exemption reason found.
- N IBX,IBZ,IBS,IBR,PDFN,LIST,NODE,ICDCT
- S PDFN=$$FILE^IBRXUTL(RX,2)
- S LIST="IBRXARREX"
- S NODE="ICD"
- D RX^PSO52API(PDFN,LIST,RX,,NODE,,)
- S ICDCT=$G(^TMP($J,LIST,PDFN,RX,"ICD",0))
- S IBR="",(IBS,IBX)=0
- I ICDCT>0 D
- .S IBX=0 F S IBX=$O(^TMP($J,LIST,PDFN,RX,"ICD",IBX)) Q:IBX'>0!(IBS) D
- ..S IBZ=$$ICD^IBRXUTL1(PDFN,RX,IBX,LIST) F IBP=2:1:8 Q:IBS I $P(IBZ,"^",IBP) S IBR=$P($T(EREASON+(IBP-1)),";",3),IBS=1
- K ^TMP($J,LIST)
- Q IBR
- EREASON ;
- ;;AO
- ;;IR
- ;;SC
- ;;SWA
- ;;MST
- ;;HNC
- ;;CV
- ;;SHAD
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCSC5C 8215 printed Feb 18, 2025@23:46:45 Page 2
- IBCSC5C ;ALB/ARH - ADD/EDIT PRESCRIPTION FILLS (CONTINUED) ;3/4/94
- +1 ;;2.0;INTEGRATED BILLING;**27,52,130,51,160,260,309,315,339,347,363,381,405,432,461**;21-MAR-94;Build 58
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- +4 ;
- DEFAULT(IFN,IBRX) ; add default DX and CPT to a prescription bill
- +1 ; if one is not in PSO. If there is, use it instead.
- +2 ; IFN = ien of bill entry
- +3 NEW IBX,IBPAR1,IBDX,IBCPT,IBDT,IBBIL,IBDXIFN,IBCPTIFN,IBY,IB52,IBC,PDFN,LIST,NODE
- +4 SET IBDXIFN=0
- +5 SET IBPAR1=$GET(^IBE(350.9,1,1))
- SET IBCPT=$PIECE(IBPAR1,U,30)
- +6 SET IBDX=$PIECE(IBPAR1,U,29)
- IF $$ICD9SYS^IBACSV($$BDATE^IBACSV(IFN))=30
- SET IBDX=$PIECE($GET(^IBE(350.9,1,7)),U,5)
- +7 SET IBBIL=$GET(^DGCR(399,+$GET(IFN),0))
- if IBBIL=""
- QUIT
- +8 SET IBX=$SELECT($GET(IBRX):$PIECE($GET(^DGCR(399,IFN,"RC",+IBRX,0)),U,11),1:$ORDER(^IBA(362.4,"C",IFN,0)))
- if 'IBX
- QUIT
- +9 SET IB52=+$PIECE($GET(^IBA(362.4,IBX,0)),"^",5)
- SET IBY=0
- if IB52=0
- QUIT
- +10 SET PDFN=$$FILE^IBRXUTL(IB52,2)
- +11 SET LIST="IBCSC5CARR"
- +12 SET NODE="ICD"
- +13 DO RX^PSO52API(PDFN,LIST,IB52,,NODE,,)
- +14 IF ^TMP($JOB,LIST,PDFN,IB52,"ICD",0)>0
- Begin DoDot:1
- +15 SET IBY=0
- FOR
- SET IBY=$ORDER(^TMP($JOB,LIST,PDFN,IB52,"ICD",IBY))
- if IBY'>0
- QUIT
- Begin DoDot:2
- +16 SET IBDX(IBY)=$$ICD^IBRXUTL1(PDFN,IB52,IBY,LIST)
- +17 IF 'IBDX(IBY)
- KILL IBDX(IBY)
- End DoDot:2
- End DoDot:1
- +18 KILL ^TMP($JOB,LIST)
- +19 IF 'IBDX
- IF 'IBCPT
- IF $DATA(IBDX)<10
- QUIT
- +20 SET IBDT=$PIECE($GET(^IBA(362.4,+IBX,0)),U,3)
- if 'IBDT
- QUIT
- +21 ; add dx associated with rx if they are there.
- +22 IF $DATA(IBDX)>9
- SET (IBC,IBDX,IBY)=0
- FOR
- SET IBY=$ORDER(IBDX(IBY))
- if 'IBY
- QUIT
- Begin DoDot:1
- +23 IF $DATA(^IBA(362.3,"AIFN"_IFN,+IBDX(IBY)))
- QUIT
- +24 SET IBC=IBC+1
- +25 SET DIC="^IBA(362.3,"
- SET DIC(0)="L"
- SET DIC("DR")=".02////"_IFN_";.03////"_IBC
- SET X=+IBDX(IBY)
- SET DLAYGO=362.3
- +26 KILL DD,DO
- DO FILE^DICN
- KILL DIC,DA,DR,DD,DO,DLAYGO
- +27 SET IBDXIFN(IBC)=+Y
- End DoDot:1
- +28 ; add default dx if none found on actual rx.
- +29 IF +IBDX
- IF '$DATA(^IBA(362.3,"AIFN"_IFN,+IBDX))
- SET DIC="^IBA(362.3,"
- SET DIC(0)="L"
- SET DIC("DR")=".02////"_IFN
- SET X=IBDX
- SET DLAYGO=362.3
- KILL DD,DO
- DO FILE^DICN
- KILL DIC,DA,DR,DD,DO,DLAYGO
- SET IBDXIFN=+Y
- +30 ;Check if the procedure is already present for the Rx
- IF +IBCPT
- Begin DoDot:1
- +31 NEW Z,Z0,DUP
- +32 SET (DUP,Z)=0
- FOR
- SET Z=$ORDER(^DGCR(399,IFN,"RC",Z))
- if 'Z
- QUIT
- SET Z0=$GET(^(Z,0))
- Begin DoDot:2
- +33 IF $PIECE(Z0,U,10)=3
- IF $PIECE(Z0,U,15)
- IF $PIECE(Z0,U,11)=IBX
- SET DUP=1
- End DoDot:2
- if DUP
- QUIT
- +34 if DUP
- QUIT
- +35 IF $PIECE($GET(^DGCR(399,IFN,0)),U,9)=""
- SET DIE="^DGCR(399,"
- SET DA=IFN
- SET DR=".09////5"
- DO ^DIE
- KILL DIE,DIC,DA,DR
- +36 IF '$DATA(^DGCR(399,IFN,"CP",0))
- SET DIC("P")=$$GETSPEC^IBEFUNC(399,304)
- +37 SET DLAYGO=399
- SET DIC("DR")="1////"_IBDT
- Begin DoDot:2
- +38 IF +IBDXIFN>0
- SET DIC("DR")=DIC("DR")_";10////"_IBDXIFN
- QUIT
- +39 IF $DATA(IBDXIFN)>9
- FOR IBY=1:1:4
- IF $DATA(IBDXIFN(IBY))
- SET DIC("DR")=DIC("DR")_";"_(IBY+9)_"////"_IBDXIFN(IBY)
- End DoDot:2
- +40 SET DIC="^DGCR(399,"_IFN_",""CP"","
- SET DIC(0)="L"
- SET DA(1)=IFN
- SET X=IBCPT_";ICPT("
- KILL DD,DO
- DO FILE^DICN
- KILL DIC,DA,DD,DO,DR,DLAYGO
- +41 IF +Y
- Begin DoDot:2
- +42 NEW Z,IBZ
- +43 SET IBZ=+Y
- SET Z=$SELECT($GET(IBREV):IBREV,1:$$FINDREV^IBCSC5A(IFN,3,+IBX))
- +44 IF Z
- SET DR=".15////"_IBZ_";.06////"_IBCPT
- SET DA=+Z
- SET DA(1)=IFN
- SET DIE="^DGCR(399,"_DA(1)_",""RC"","
- DO ^DIE
- End DoDot:2
- End DoDot:1
- +45 QUIT
- +46 ;
- RXDISP(DFN,DT1,DT2,ARRAY,POARR,RXARR,IBRXALL,NODISP) ; display all rx fills for a patient and date range
- +1 ;RXARR (as defined by SET^IBCSC5A) passed by ref. only to check if rx-fill is on the bill, not necessary not changed
- +2 ;returns: ARRAY(RX #, FILL DT) = RX IFN (52) ^ FILL IFN ^ DRUG ^ DAYS SUPPLY ^ QTY ^ NDC ^ ORDER DATE, pass by reference if desired
- +3 ; POARR(CNT)=RX # ^ FILL DT
- +4 NEW PIFN,RIFN,IBX,IBY,DTE,DTR,RX,IBCNT,IBRX0,IBRX2,IBS,LIST,LIST2
- KILL ARRAY,POARR
- SET POARR=0
- SET NODISP=+$GET(NODISP)
- +5 SET IBCNT=0
- SET DT1=$GET(DT1)-.0001
- SET DT2=$GET(DT2)
- if 'DT2
- SET DT2=9999999
- if '$GET(DFN)
- QUIT
- +6 ;^PS(55,DFN,"P","A",EXPIRATION DATE, RX) is the best xref available for finding patient fills in a date range
- +7 ;if RX expires/cancelled before start of bill then should not be applicable to bill
- +8 SET LIST="IBRXDISPARR"
- +9 DO PROF^PSO52API(DFN,LIST,DT1)
- +10 SET DTE=0
- FOR
- SET DTE=$ORDER(^TMP($JOB,LIST,"B",DTE))
- if 'DTE
- QUIT
- Begin DoDot:1
- +11 SET PIFN=0
- FOR
- SET PIFN=$ORDER(^TMP($JOB,LIST,"B",DTE,PIFN))
- if 'PIFN
- QUIT
- Begin DoDot:2
- +12 SET IBRX0=$$RXZERO^IBRXUTL(DFN,PIFN)
- SET IBRX2=$$RXSEC^IBRXUTL(DFN,PIFN)
- +13 ; original fill
- +14 IF +$GET(IBRXALL)
- SET DTR=$PIECE(IBRX2,U,2)
- IF DTR'<DT1
- IF DTR'>DT2
- Begin DoDot:3
- +15 DO DATA^IBRXUTL(+$PIECE(IBRX0,U,6))
- +16 ; add issue date to array so order date can be displayed
- +17 ;S ARRAY($P(IBRX0,U,1),+DTR)=PIFN_U_0_U_$P(IBRX0,U,6)_U_$P(IBRX0,U,8)_U_$P(IBRX0,U,7)_U_$$GETNDC^PSONDCUT(PIFN,0)
- +18 SET ARRAY($PIECE(IBRX0,U,1),+DTR)=PIFN_U_0_U_$PIECE(IBRX0,U,6)_U_$PIECE(IBRX0,U,8)_U_$PIECE(IBRX0,U,7)_U_$$GETNDC^PSONDCUT(PIFN,0)_U_$PIECE(IBRX0,U,13)
- +19 KILL ^TMP($JOB,"IBDRUG")
- +20 QUIT
- End DoDot:3
- +21 ; refills
- +22 SET LIST2="IBDISPSUB"
- +23 SET NODE="R"
- +24 DO RX^PSO52API(DFN,LIST2,PIFN,,NODE,,)
- +25 SET RIFN=0
- FOR
- SET RIFN=$ORDER(^TMP($JOB,LIST2,DFN,PIFN,"RF",RIFN))
- if RIFN'>0
- QUIT
- Begin DoDot:3
- +26 SET IBY=$$ZEROSUB^IBRXUTL(DFN,PIFN,RIFN)
- if IBY=""
- QUIT
- +27 if +IBY<DT1!(+IBY>DT2)
- QUIT
- +28 DO DATA^IBRXUTL(+$PIECE(IBRX0,U,6))
- +29 ; add issue date to array so order date can be displayed
- +30 ;S ARRAY($P(IBRX0,U,1),+IBY)=PIFN_U_RIFN_U_$P(IBRX0,U,6)_U_$P(IBRX0,U,8)_U_$P(IBY,U,4)_U_$$GETNDC^PSONDCUT(PIFN,RIFN)
- +31 SET ARRAY($PIECE(IBRX0,U,1),+IBY)=PIFN_U_RIFN_U_$PIECE(IBRX0,U,6)_U_$PIECE(IBRX0,U,8)_U_$PIECE(IBY,U,4)_U_$$GETNDC^PSONDCUT(PIFN,RIFN)_U_$PIECE(IBRX0,U,13)
- +32 KILL ^TMP($JOB,"IBDRUG")
- +33 QUIT
- End DoDot:3
- +34 KILL ^TMP($JOB,LIST2)
- End DoDot:2
- End DoDot:1
- +35 KILL ^TMP($JOB,LIST)
- +36 ;
- +37 SET IBX=""
- SET IBS=0
- FOR
- SET IBX=$ORDER(ARRAY(IBX))
- if IBX=""
- QUIT
- SET IBY=0
- FOR
- SET IBY=$ORDER(ARRAY(IBX,IBY))
- if 'IBY
- QUIT
- Begin DoDot:1
- +38 SET IBCNT=IBCNT+1
- SET POARR(IBCNT)=$PIECE(IBX,U,1)_"^"_+IBY
- SET POARR=IBCNT
- IF $DATA(RXARR(IBX,IBY))
- SET IBS=IBS+1
- End DoDot:1
- +39 SET $PIECE(POARR,U,2)=IBCNT-IBS
- +40 ;
- +41 if +NODISP
- QUIT
- +42 WRITE @IOF,?33,"PRESCRIPTIONS IN DATE RANGE",!,"===============================================================================",!
- +43 SET IBCNT=0
- FOR
- SET IBCNT=$ORDER(POARR(IBCNT))
- if IBCNT=""
- QUIT
- SET RX=$PIECE(POARR(IBCNT),U,1)
- SET DTR=$PIECE(POARR(IBCNT),U,2)
- IF RX'=""
- IF DTR'=""
- Begin DoDot:1
- +44 SET IBS=$$RXSTAT^IBCU1($PIECE(ARRAY(RX,DTR),U,3),$PIECE(ARRAY(RX,DTR),U,1),DTR)
- +45 SET IBY=""
- IF $DATA(RXARR(RX,+DTR))
- SET IBY="*"
- +46 DO ZERO^IBRXUTL(+$PIECE(ARRAY(RX,DTR),U,3))
- +47 WRITE !,$JUSTIFY(IBCNT,2),")",?5,IBY,?6,RX,?19,$EXTRACT($GET(^TMP($JOB,"IBDRUG",+$PIECE(ARRAY(RX,DTR),U,3),.01)),1,25),?46,$$DATE(+DTR),?56,$PIECE(IBS,U,1),?61,$PIECE(IBS,U,2),?69,$PIECE(IBS,U,3),?75,$$EXEMPT(+ARRAY(RX,DTR))
- +48 SET IBY=$$RXDUP^IBCU3(RX,DTR,IBIFN)
- IF +IBY
- WRITE ?73,$PIECE($GET(^DGCR(399,+IBY,0)),U,1)
- +49 KILL ^TMP($JOB,"IBDRUG")
- End DoDot:1
- +50 QUIT
- DATE(X) QUIT $EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)
- +1 ;
- NEWRX(IBX) ;
- +1 if '$GET(IBX)
- QUIT
- NEW X,Y
- KILL IBLIST
- WRITE !
- NEWRX1 SET DIR("?")="Enter the number preceding the RX Fills you want added to the bill. "_$$HTEXT
- +1 SET DIR("A")="SELECT NEW RX FILLS TO ADD THE BILL"
- +2 SET DIR(0)="LO^1:"_+IBX
- DO ^DIR
- KILL DIR
- if 'Y!$DATA(DIRUT)
- GOTO NEWRXE
- +3 SET IBLIST=Y
- +4 ;
- +5 SET DIR("A")="YOU HAVE SELECTED "_IBLIST_" TO BE ADDED TO THE BILL IS THIS CORRECT"
- SET DIR("B")="YES"
- +6 SET DIR(0)="YO"
- DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- KILL IBLIST
- GOTO NEWRXE
- +7 IF 'Y
- KILL IBLIST
- GOTO NEWRX1
- NEWRXE QUIT
- +1 ;
- ADDNEW(IBIFN,LIST,IBPR,IBPRO) ;
- +1 if 'LIST
- QUIT
- NEW IBI,IBX,IBRX,IBDT,IBQ,IBY,IBPIFN,IBZ
- +2 FOR IBI=1:1
- SET IBX=$PIECE(LIST,",",IBI)
- if 'IBX
- QUIT
- IF $DATA(IBPRO(IBX))
- Begin DoDot:1
- +3 SET IBRX=$PIECE(IBPRO(IBX),U,1)
- SET IBDT=$PIECE(IBPRO(IBX),U,2)
- if IBRX=""
- QUIT
- +4 SET IBQ=0
- SET IBY=$GET(IBPR(IBRX,+IBDT))
- if 'IBY
- QUIT
- +5 SET IBPIFN=0
- FOR
- SET IBPIFN=$ORDER(^IBA(362.4,"AIFN"_IBIFN,IBRX,IBPIFN))
- if 'IBPIFN
- QUIT
- IF $PIECE($GET(^IBA(362.4,IBPIFN,0)),U,3)=IBDT
- SET IBQ=1
- QUIT
- +6 ;I 'IBQ S IBZ=$G(IBPR(IBRX,IBDT)) I $$ADD^IBCSC5A(IBRX,IBIFN,IBDT,$P(IBZ,U,3),$P(IBZ,U,1),$P(IBZ,U,4,6),$P(IBZ,U,2)) W "."
- +7 ; IB*2.0*432 - include issue date from file 52 to display to user when adding
- +8 IF 'IBQ
- SET IBZ=$GET(IBPR(IBRX,IBDT))
- IF $$ADD^IBCSC5A(IBRX,IBIFN,IBDT,$PIECE(IBZ,U,3),$PIECE(IBZ,U,1),$PIECE(IBZ,U,4,7),$PIECE(IBZ,U,2))
- WRITE "."
- End DoDot:1
- +9 QUIT
- +10 ;
- HTEXT() ;
- +1 NEW X
- SET X="If an Rx fill has been assigned to another bill it will be displayed in the last column. [ORG=Original Fill, NR=Not Released, RTS=Returned to Stock, OTC=Over-the-Counter, INV=Investigational, SUP=Supply Item]"
- +2 QUIT X
- +3 ;
- RXLINK(IBIFN,CPIEN) ; Function returns the ien of the Rx rev code the proc
- +1 ; code is linked to or 0 if no link found.
- +2 QUIT +$ORDER(^DGCR(399,IBIFN,"RC","ACP",+CPIEN,0))
- +3 ;
- EXEMPT(RX) ; Used to look up exemption if any on rx, the return value
- +1 ; will be only the first exemption reason found.
- +2 NEW IBX,IBZ,IBS,IBR,PDFN,LIST,NODE,ICDCT
- +3 SET PDFN=$$FILE^IBRXUTL(RX,2)
- +4 SET LIST="IBRXARREX"
- +5 SET NODE="ICD"
- +6 DO RX^PSO52API(PDFN,LIST,RX,,NODE,,)
- +7 SET ICDCT=$GET(^TMP($JOB,LIST,PDFN,RX,"ICD",0))
- +8 SET IBR=""
- SET (IBS,IBX)=0
- +9 IF ICDCT>0
- Begin DoDot:1
- +10 SET IBX=0
- FOR
- SET IBX=$ORDER(^TMP($JOB,LIST,PDFN,RX,"ICD",IBX))
- if IBX'>0!(IBS)
- QUIT
- Begin DoDot:2
- +11 SET IBZ=$$ICD^IBRXUTL1(PDFN,RX,IBX,LIST)
- FOR IBP=2:1:8
- if IBS
- QUIT
- IF $PIECE(IBZ,"^",IBP)
- SET IBR=$PIECE($TEXT(EREASON+(IBP-1)),";",3)
- SET IBS=1
- End DoDot:2
- End DoDot:1
- +12 KILL ^TMP($JOB,LIST)
- +13 QUIT IBR
- EREASON ;
- +1 ;;AO
- +2 ;;IR
- +3 ;;SC
- +4 ;;SWA
- +5 ;;MST
- +6 ;;HNC
- +7 ;;CV
- +8 ;;SHAD
- +9 ;
