- IBOCHK ;ALB/AAS - INTEGRATED BILLING - RX COPAY LINK CHECK ; 2-APR-91
- ;;2.0;INTEGRATED BILLING;**347**; 21-MAR-94;Build 24
- ;
- ; -loop through range of IB reference numbers and verify
- ; soft link exists and has link back to IB.
- ;
- % ;
- ;***
- ;S XRTL=$ZU(0),XRTN="IBOCHK-1" D T0^%ZOSV ;start rt clock
- ;
- D HOME^%ZIS W @IOF,?24,"Verify IB - Pharmacy Co-Pay links",!!
- ;
- ST S DIC="^IB(",DIC(0)="AEQMN",DIC("A")="START WITH REFERENCE NUMBER:",DIC("B")="" D ^DIC K DIC G:+Y<1 END S IBSTART=$P(Y,"^",2)
- ;
- TO S DIC="^IB(",DIC(0)="AEQMN",DIC("A")="GO TO REFERENCE NUMBER: ",DIC("B")="" D ^DIC K DIC G:+Y<1 END S IBEND=$P(Y,"^",2)
- I IBSTART>IBEND W *7,!!,"End must not be less than beginning number",! G ST
- ;
- DEV W !!,"*** Margin width of this output is 132 ***"
- W ! S %ZIS="QM",%ZIS("A")="Output Device: " D ^%ZIS G:POP END
- I $D(IO("Q")) S ZTRTN="DQ^IBOCHK",ZTDESC="IB Check Pharmacy Links",ZTSAVE("IB*")="" D ^%ZTLOAD K IO("Q") W ! G END
- ;
- U IO
- ;***
- ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOCHK" D T1^%ZOSV ;stop rt clock
- ;
- DQ ; -entry point from queing
- ;S XRTL=$ZU(0),XRTN="IBOCHK-2" D T0^%ZOSV ;start rt clock
- ;
- S (IBCNT,IBECNT)=0,IBPAG=0,IBQUIT=0 S Y=DT D D^DIQ S IBHDT=Y D HDR
- S IBRNUM=IBSTART-1
- F S IBRNUM=$O(^IB("B",IBRNUM)) Q:'IBRNUM!(IBRNUM>IBEND)!(IBQUIT) S IBN="" F S IBN=$O(^IB("B",IBRNUM,IBN)) Q:'IBN!(IBQUIT) D CHK
- G END
- ;
- CHK S IBCNT=IBCNT+1
- N DFN,IBNODE
- I '$D(^IB(IBN,0))!('$D(^IB(IBN,1))) S IBOERR=1,IBND=IBN G LINE ;xref to no entry
- S IBND=$S($D(^IB(IBN,0)):^(0),1:"")
- S IBSL=$P(^IB(IBN,0),"^",4) I 'IBSL S IBOERR=2 G LINE ;no softlink
- I +IBSL'=52 Q ;not a pharmacy rx entry
- S IBRXN=$P($P(IBSL,";"),":",2),IBRXN1=$P($P(IBSL,";",2),":",2)
- S DFN=$P(^IB(IBN,0),"^",2)
- I $$FILE^IBRXUTL(IBRXN,.01)="" S IBOERR=3 G LINE ;rx deleted
- S IBNODE=$$IBND^IBRXUTL(DFN,IBRXN)
- I IBNODE'["^" S IBOERR=4 G LINE ;IB node missing
- I +IBNODE,'$P(IBNODE,"^",2) S IBOERR=5 G LINE ;pointer back to IB missing
- Q:'IBRXN1
- I +$$SUBFILE^IBRXUTL(IBRXN,IBRXN1,52,.01)=0 S IBOERR=6 G LINE ;refill deleted
- I $$IBNDFL^IBRXUTL(DFN,IBRXN,IBRXN1)'["^" S IBOERR=7 G LINE ;ib node on refill missing
- I +$$IBNDFL^IBRXUTL(DFN,IBRXN,IBRXN1)=0 S IBOERR=8 G LINE ;no data on node
- Q ;pharmacy links okay.
- ;
- HDR ;
- S IBPAG=IBPAG+1
- W:$E(IOST,1,2)["C-"!(IBPAG>1) @IOF
- W "Verify Integrated Billing links to Pharmacy",?IOM-22,IBHDT," Page:",IBPAG
- W !,"Verify IB Reference Number ",IBSTART," to ",IBEND
- W !,"REF. NO.",?12,"PATIENT",?34,"SSN",?40,"RX#",?50,"REFILL",?58,"IB LINK",?80,"CHARGE ID",?91,"TRANS",?97,"ERROR MESSAGE"
- S $P(IBLINE,"-",IOM)="" W !,IBLINE K IBLINE
- Q
- LINE ;
- I $Y>(IOSL-5) D PAUSE^IBOUTL Q:IBQUIT D HDR
- S IBECNT=IBECNT+1
- W !,$P(IBND,"^") S DFN=$P(IBND,"^",2)
- I $D(^DPT(+DFN,0)) D PID^VADPT W ?12,$E($P(^DPT(DFN,0),"^"),1,20),?34,VA("BID"),?40,$P($P(IBND,"^",8),"-"),?50,$P($P(IBSL,";",2),":",2),?58,IBSL,?80,$P(IBND,"^",11),?91,$P(IBND,"^",12)
- W ?97,$P($T(IBOERR+IBOERR),";;",2,99)
- Q
- ;
- END ;
- ;***
- I $D(XRT0) S:'$D(XRTN) XRTN="IBOCHK" D T1^%ZOSV ;stop rt clock
- ;
- Q:$D(ZTQUEUED) K IBCNT,IBECNT,IBEND,IHDT,IBN,IBND,IBPAG,IBQUIT,IBRNUM,IBRXN,IBRXN1,IBSL,IBSTART
- D ^%ZISC
- Q
- IBOERR ;error messages
- ;;IB CROSS-REFERENCE BUT NO ENTRY
- ;;IB ENTRY MISSING SOFTLINK
- ;;RX ENTRY DELETED OR ARCHIVED
- ;;RX ENTRY MISSING IB NODE
- ;;RX ENTRY MISSING IB POINTER
- ;;RX REFILL DELETED
- ;;RX REFILL MISSING IB NODE
- ;;RX REFILL MISSING IB LINK
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOCHK 3448 printed Mar 13, 2025@21:30:20 Page 2
- IBOCHK ;ALB/AAS - INTEGRATED BILLING - RX COPAY LINK CHECK ; 2-APR-91
- +1 ;;2.0;INTEGRATED BILLING;**347**; 21-MAR-94;Build 24
- +2 ;
- +3 ; -loop through range of IB reference numbers and verify
- +4 ; soft link exists and has link back to IB.
- +5 ;
- % ;
- +1 ;***
- +2 ;S XRTL=$ZU(0),XRTN="IBOCHK-1" D T0^%ZOSV ;start rt clock
- +3 ;
- +4 DO HOME^%ZIS
- WRITE @IOF,?24,"Verify IB - Pharmacy Co-Pay links",!!
- +5 ;
- ST SET DIC="^IB("
- SET DIC(0)="AEQMN"
- SET DIC("A")="START WITH REFERENCE NUMBER:"
- SET DIC("B")=""
- DO ^DIC
- KILL DIC
- if +Y<1
- GOTO END
- SET IBSTART=$PIECE(Y,"^",2)
- +1 ;
- TO SET DIC="^IB("
- SET DIC(0)="AEQMN"
- SET DIC("A")="GO TO REFERENCE NUMBER: "
- SET DIC("B")=""
- DO ^DIC
- KILL DIC
- if +Y<1
- GOTO END
- SET IBEND=$PIECE(Y,"^",2)
- +1 IF IBSTART>IBEND
- WRITE *7,!!,"End must not be less than beginning number",!
- GOTO ST
- +2 ;
- DEV WRITE !!,"*** Margin width of this output is 132 ***"
- +1 WRITE !
- SET %ZIS="QM"
- SET %ZIS("A")="Output Device: "
- DO ^%ZIS
- if POP
- GOTO END
- +2 IF $DATA(IO("Q"))
- SET ZTRTN="DQ^IBOCHK"
- SET ZTDESC="IB Check Pharmacy Links"
- SET ZTSAVE("IB*")=""
- DO ^%ZTLOAD
- KILL IO("Q")
- WRITE !
- GOTO END
- +3 ;
- +4 USE IO
- +5 ;***
- +6 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOCHK" D T1^%ZOSV ;stop rt clock
- +7 ;
- DQ ; -entry point from queing
- +1 ;S XRTL=$ZU(0),XRTN="IBOCHK-2" D T0^%ZOSV ;start rt clock
- +2 ;
- +3 SET (IBCNT,IBECNT)=0
- SET IBPAG=0
- SET IBQUIT=0
- SET Y=DT
- DO D^DIQ
- SET IBHDT=Y
- DO HDR
- +4 SET IBRNUM=IBSTART-1
- +5 FOR
- SET IBRNUM=$ORDER(^IB("B",IBRNUM))
- if 'IBRNUM!(IBRNUM>IBEND)!(IBQUIT)
- QUIT
- SET IBN=""
- FOR
- SET IBN=$ORDER(^IB("B",IBRNUM,IBN))
- if 'IBN!(IBQUIT)
- QUIT
- DO CHK
- +6 GOTO END
- +7 ;
- CHK SET IBCNT=IBCNT+1
- +1 NEW DFN,IBNODE
- +2 ;xref to no entry
- IF '$DATA(^IB(IBN,0))!('$DATA(^IB(IBN,1)))
- SET IBOERR=1
- SET IBND=IBN
- GOTO LINE
- +3 SET IBND=$SELECT($DATA(^IB(IBN,0)):^(0),1:"")
- +4 ;no softlink
- SET IBSL=$PIECE(^IB(IBN,0),"^",4)
- IF 'IBSL
- SET IBOERR=2
- GOTO LINE
- +5 ;not a pharmacy rx entry
- IF +IBSL'=52
- QUIT
- +6 SET IBRXN=$PIECE($PIECE(IBSL,";"),":",2)
- SET IBRXN1=$PIECE($PIECE(IBSL,";",2),":",2)
- +7 SET DFN=$PIECE(^IB(IBN,0),"^",2)
- +8 ;rx deleted
- IF $$FILE^IBRXUTL(IBRXN,.01)=""
- SET IBOERR=3
- GOTO LINE
- +9 SET IBNODE=$$IBND^IBRXUTL(DFN,IBRXN)
- +10 ;IB node missing
- IF IBNODE'["^"
- SET IBOERR=4
- GOTO LINE
- +11 ;pointer back to IB missing
- IF +IBNODE
- IF '$PIECE(IBNODE,"^",2)
- SET IBOERR=5
- GOTO LINE
- +12 if 'IBRXN1
- QUIT
- +13 ;refill deleted
- IF +$$SUBFILE^IBRXUTL(IBRXN,IBRXN1,52,.01)=0
- SET IBOERR=6
- GOTO LINE
- +14 ;ib node on refill missing
- IF $$IBNDFL^IBRXUTL(DFN,IBRXN,IBRXN1)'["^"
- SET IBOERR=7
- GOTO LINE
- +15 ;no data on node
- IF +$$IBNDFL^IBRXUTL(DFN,IBRXN,IBRXN1)=0
- SET IBOERR=8
- GOTO LINE
- +16 ;pharmacy links okay.
- QUIT
- +17 ;
- HDR ;
- +1 SET IBPAG=IBPAG+1
- +2 if $EXTRACT(IOST,1,2)["C-"!(IBPAG>1)
- WRITE @IOF
- +3 WRITE "Verify Integrated Billing links to Pharmacy",?IOM-22,IBHDT," Page:",IBPAG
- +4 WRITE !,"Verify IB Reference Number ",IBSTART," to ",IBEND
- +5 WRITE !,"REF. NO.",?12,"PATIENT",?34,"SSN",?40,"RX#",?50,"REFILL",?58,"IB LINK",?80,"CHARGE ID",?91,"TRANS",?97,"ERROR MESSAGE"
- +6 SET $PIECE(IBLINE,"-",IOM)=""
- WRITE !,IBLINE
- KILL IBLINE
- +7 QUIT
- LINE ;
- +1 IF $Y>(IOSL-5)
- DO PAUSE^IBOUTL
- if IBQUIT
- QUIT
- DO HDR
- +2 SET IBECNT=IBECNT+1
- +3 WRITE !,$PIECE(IBND,"^")
- SET DFN=$PIECE(IBND,"^",2)
- +4 IF $DATA(^DPT(+DFN,0))
- DO PID^VADPT
- WRITE ?12,$EXTRACT($PIECE(^DPT(DFN,0),"^"),1,20),?34,VA("BID"),?40,$PIECE($PIECE(IBND,"^",8),"-"),?50,$PIECE($PIECE(IBSL,";",2),":",2),?58,IBSL,?80,$PIECE(IBND,"^",11),?91,$PIECE(IBND,"^",12)
- +5 WRITE ?97,$PIECE($TEXT(IBOERR+IBOERR),";;",2,99)
- +6 QUIT
- +7 ;
- END ;
- +1 ;***
- +2 ;stop rt clock
- IF $DATA(XRT0)
- if '$DATA(XRTN)
- SET XRTN="IBOCHK"
- DO T1^%ZOSV
- +3 ;
- +4 if $DATA(ZTQUEUED)
- QUIT
- KILL IBCNT,IBECNT,IBEND,IHDT,IBN,IBND,IBPAG,IBQUIT,IBRNUM,IBRXN,IBRXN1,IBSL,IBSTART
- +5 DO ^%ZISC
- +6 QUIT
- IBOERR ;error messages
- +1 ;;IB CROSS-REFERENCE BUT NO ENTRY
- +2 ;;IB ENTRY MISSING SOFTLINK
- +3 ;;RX ENTRY DELETED OR ARCHIVED
- +4 ;;RX ENTRY MISSING IB NODE
- +5 ;;RX ENTRY MISSING IB POINTER
- +6 ;;RX REFILL DELETED
- +7 ;;RX REFILL MISSING IB NODE
- +8 ;;RX REFILL MISSING IB LINK
