IBEMTBC ;ALB/RLW - IB MEANS TEST BILLING CLOCK FILE UPDATE ; 15-JAN-92
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
EN ; Entry point for Clock Maintenance
;
;I $D(XRT0) S:'$D(XRTN) XRTN="IBEMTBC" D T1^%ZOSV ;stop rt clock
;S XRTL=$ZU(0),XRTN="IBEMTBC-1" D T0^%ZOSV ;start rt clock
;
D HOME^%ZIS,NOW^%DTC S IBDT=% K % I '$D(DT) D DT^DICRW
S DIR(0)="PO^2:AEMQZ" D ^DIR K DIR S DFN=+Y I $D(DIRUT) G ENQ
I $$BILST^DGMTUB(DFN)=0 S J=5 D ERR G EN
I $D(^IBE(351,"ACT",DFN)) S IBSELECT="ADJUST",IBDR="[IB BILLING CYCLE ADJUST]" D ADJUST,CLEANUP G ENQ
S IBSELECT="ADD",IBDR="[IB BILLING CYCLE ADD]" D ADDNEW,CLEANUP
;
ENQ I '$D(DIRUT) W ! G EN
K DIC,IBSELECT,DFN,IBDR,IBEL,DFN,IBIEN,IBDATA,J,DIRUT,IBFAC,IBSITE,IBDT
;
;I $D(XRT0) S:'$D(XRTN) XRTN="IBEMTBC" D T1^%ZOSV ;stop rt clock
;
Q
;
ADJUST ; - show current active clock; inactivate and add a new one
W @IOF
S IBIEN=$O(^IBE(351,"ACT",DFN,0))
S DIC="^IBE(351,",DA=IBIEN W !! D EN^DIQ K DIC,DA
S DIR(0)="Y",DIR("A")="Do you want to update" D ^DIR K DIR Q:+Y<1
;
; - save current clock, change to cancelled and delete "ACT" xref
K ^IBE(351,"ACT",DFN) L +(^IBE(351,IBIEN))
S IBDATA=$P(^IBE(351,IBIEN,0),"^",2,10),$P(^IBE(351,IBIEN,0),"^",4)=3,$P(^(1),"^",3,4)=DUZ_"^"_IBDT
L -(^IBE(351,IBIEN))
;
ADDNEW ; - add a new clock and allow updating
I IBSELECT="ADD" D Q:'Y W !
.W !!,"This patient does not have an active billing clock!"
.S DIR(0)="Y",DIR("A")="Is it okay to add a new billing clock for this patient"
.D ^DIR K DIR,DIRUT,DUOUT,DTOUT
;
D SITE^IBAUTL I 'IBSITE S J=1 G ERR
S I=$P($S($D(^IBE(351,0)):^(0),1:"^^-1"),"^",3)+1 I 'I S J=3 G ERR
K DD,DO,DIC,DR S DIC="^IBE(351,",DIC(0)="L",DLAYGO=351,DIC("DR")=".02////"_DFN_";11////"_DUZ_";12////"_IBDT
F I=I:1 I I>0,'$D(^IBE(351,I)) L +^IBE(351,I):2 I $T,'$D(^IBE(351,I)) S DINUM=I,X=+IBSITE_I D FILE^DICN K DIC,DR S IBCL=+Y Q:+Y>0
I IBSELECT'="ADD" S $P(^IBE(351,IBCL,0),"^",2,10)=IBDATA,DIK="^IBE(351,",DA=IBCL D IX1^DIK K DIK
S DIE="^IBE(351,",DA=IBCL,DR=IBDR D ^DIE K DA,DIE,DR
L -^IBE(351,IBCL)
;
; - if the updated clock was cancelled, with no other changes made,
; - move the update reason over to the old clock and cancel the new one.
I IBSELECT'="ADD" D
.I $L(^IBE(351,+$G(IBIEN),0),"^")=9 S $P(^IBE(351,+$G(IBIEN),0),"^",10)=""
.I $L(^IBE(351,IBCL,0),"^")=9 S $P(^IBE(351,IBCL,0),"^",10)=""
.Q:$P(^IBE(351,+$G(IBIEN),0),"^",2,10)'=$P(^IBE(351,IBCL,0),"^",2,10)
.W !!,"Since you only cancelled the clock, I'll delete the new clock..."
.I $P(^IBE(351,IBCL,0),"^",11)]"" S $P(^IBE(351,+$G(IBIEN),0),"^",11)=$P(^IBE(351,IBCL,0),"^",11) W !,"(but I'll save the update reason)..."
.S DA=IBCL,DIK="^IBE(351," D ^DIK K DIK,DA
;
; - if the user is adding a new clock, and there is no clock
; - begin date or status, delete the clock.
I IBSELECT="ADD" S IBDATA=^IBE(351,IBCL,0) I '$P(IBDATA,"^",3)!'$P(IBDATA,"^",4) D
.W !!,"This new clock is incomplete!! Deleting the clock from the system..."
.S DA=IBCL,DIK="^IBE(351," D ^DIK K DIK,DA
K IBCL
Q
;
ERR ; - display error messages
W !?5,$P($T(ERRMSG+J),";;",2)
CLEANUP K IBCLDA,IBCLDAY,IBCLDT,IBMED,IBCLDOL,X,IBSELECT,DLAYGO,IBDT
Q
;
ERRMSG ; - possible error messages
;;No value returned from call to SITE^IBAUTL
;;Record locked, try again later!
;;Problem extracting last IFN from zeroth node of CATEGORY C BILLING CLOCK file
;;Unable to add record to CATEGORY C BILLING CLOCK file
;;Not a Category C patient!
IBEMTBC ;ALB/RLW - IB MEANS TEST BILLING CLOCK FILE UPDATE ; 15-JAN-92
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
EN ; Entry point for Clock Maintenance
+1 ;
+2 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBEMTBC" D T1^%ZOSV ;stop rt clock
+3 ;S XRTL=$ZU(0),XRTN="IBEMTBC-1" D T0^%ZOSV ;start rt clock
+4 ;
+5 DO HOME^%ZIS
DO NOW^%DTC
SET IBDT=%
KILL %
IF '$DATA(DT)
DO DT^DICRW
+6 SET DIR(0)="PO^2:AEMQZ"
DO ^DIR
KILL DIR
SET DFN=+Y
IF $DATA(DIRUT)
GOTO ENQ
+7 IF $$BILST^DGMTUB(DFN)=0
SET J=5
DO ERR
GOTO EN
+8 IF $DATA(^IBE(351,"ACT",DFN))
SET IBSELECT="ADJUST"
SET IBDR="[IB BILLING CYCLE ADJUST]"
DO ADJUST
DO CLEANUP
GOTO ENQ
+9 SET IBSELECT="ADD"
SET IBDR="[IB BILLING CYCLE ADD]"
DO ADDNEW
DO CLEANUP
+10 ;
ENQ IF '$DATA(DIRUT)
WRITE !
GOTO EN
+1 KILL DIC,IBSELECT,DFN,IBDR,IBEL,DFN,IBIEN,IBDATA,J,DIRUT,IBFAC,IBSITE,IBDT
+2 ;
+3 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBEMTBC" D T1^%ZOSV ;stop rt clock
+4 ;
+5 QUIT
+6 ;
ADJUST ; - show current active clock; inactivate and add a new one
+1 WRITE @IOF
+2 SET IBIEN=$ORDER(^IBE(351,"ACT",DFN,0))
+3 SET DIC="^IBE(351,"
SET DA=IBIEN
WRITE !!
DO EN^DIQ
KILL DIC,DA
+4 SET DIR(0)="Y"
SET DIR("A")="Do you want to update"
DO ^DIR
KILL DIR
IF +Y<1
QUIT
+5 ;
+6 ; - save current clock, change to cancelled and delete "ACT" xref
+7 KILL ^IBE(351,"ACT",DFN)
LOCK +(^IBE(351,IBIEN))
+8 SET IBDATA=$PIECE(^IBE(351,IBIEN,0),"^",2,10)
SET $PIECE(^IBE(351,IBIEN,0),"^",4)=3
SET $PIECE(^(1),"^",3,4)=DUZ_"^"_IBDT
+9 LOCK -(^IBE(351,IBIEN))
+10 ;
ADDNEW ; - add a new clock and allow updating
+1 IF IBSELECT="ADD"
Begin DoDot:1
+2 WRITE !!,"This patient does not have an active billing clock!"
+3 SET DIR(0)="Y"
SET DIR("A")="Is it okay to add a new billing clock for this patient"
+4 DO ^DIR
KILL DIR,DIRUT,DUOUT,DTOUT
End DoDot:1
IF 'Y
QUIT
WRITE !
+5 ;
+6 DO SITE^IBAUTL
IF 'IBSITE
SET J=1
GOTO ERR
+7 SET I=$PIECE($SELECT($DATA(^IBE(351,0)):^(0),1:"^^-1"),"^",3)+1
IF 'I
SET J=3
GOTO ERR
+8 KILL DD,DO,DIC,DR
SET DIC="^IBE(351,"
SET DIC(0)="L"
SET DLAYGO=351
SET DIC("DR")=".02////"_DFN_";11////"_DUZ_";12////"_IBDT
+9 FOR I=I:1
IF I>0
IF '$DATA(^IBE(351,I))
LOCK +^IBE(351,I):2
IF $TEST
IF '$DATA(^IBE(351,I))
SET DINUM=I
SET X=+IBSITE_I
DO FILE^DICN
KILL DIC,DR
SET IBCL=+Y
IF +Y>0
QUIT
+10 IF IBSELECT'="ADD"
SET $PIECE(^IBE(351,IBCL,0),"^",2,10)=IBDATA
SET DIK="^IBE(351,"
SET DA=IBCL
DO IX1^DIK
KILL DIK
+11 SET DIE="^IBE(351,"
SET DA=IBCL
SET DR=IBDR
DO ^DIE
KILL DA,DIE,DR
+12 LOCK -^IBE(351,IBCL)
+13 ;
+14 ; - if the updated clock was cancelled, with no other changes made,
+15 ; - move the update reason over to the old clock and cancel the new one.
+16 IF IBSELECT'="ADD"
Begin DoDot:1
+17 IF $LENGTH(^IBE(351,+$GET(IBIEN),0),"^")=9
SET $PIECE(^IBE(351,+$GET(IBIEN),0),"^",10)=""
+18 IF $LENGTH(^IBE(351,IBCL,0),"^")=9
SET $PIECE(^IBE(351,IBCL,0),"^",10)=""
+19 IF $PIECE(^IBE(351,+$GET(IBIEN),0),"^",2,10)'=$PIECE(^IBE(351,IBCL,0),"^",2,10)
QUIT
+20 WRITE !!,"Since you only cancelled the clock, I'll delete the new clock..."
+21 IF $PIECE(^IBE(351,IBCL,0),"^",11)]""
SET $PIECE(^IBE(351,+$GET(IBIEN),0),"^",11)=$PIECE(^IBE(351,IBCL,0),"^",11)
WRITE !,"(but I'll save the update reason)..."
+22 SET DA=IBCL
SET DIK="^IBE(351,"
DO ^DIK
KILL DIK,DA
End DoDot:1
+23 ;
+24 ; - if the user is adding a new clock, and there is no clock
+25 ; - begin date or status, delete the clock.
+26 IF IBSELECT="ADD"
SET IBDATA=^IBE(351,IBCL,0)
IF '$PIECE(IBDATA,"^",3)!'$PIECE(IBDATA,"^",4)
Begin DoDot:1
+27 WRITE !!,"This new clock is incomplete!! Deleting the clock from the system..."
+28 SET DA=IBCL
SET DIK="^IBE(351,"
DO ^DIK
KILL DIK,DA
End DoDot:1
+29 KILL IBCL
+30 QUIT
+31 ;
ERR ; - display error messages
+1 WRITE !?5,$PIECE($TEXT(ERRMSG+J),";;",2)
CLEANUP KILL IBCLDA,IBCLDAY,IBCLDT,IBMED,IBCLDOL,X,IBSELECT,DLAYGO,IBDT
+1 QUIT
+2 ;
ERRMSG ; - possible error messages
+1 ;;No value returned from call to SITE^IBAUTL
+2 ;;Record locked, try again later!
+3 ;;Problem extracting last IFN from zeroth node of CATEGORY C BILLING CLOCK file
+4 ;;Unable to add record to CATEGORY C BILLING CLOCK file
+5 ;;Not a Category C patient!
