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 Dec 13, 2024@02:25:19 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
