IBARXMN ;LL/ELZ-PHARMCAY COPAY CAP RX PROCESSING ; 15 Jun 2021 11:46 AM
;;2.0;INTEGRATED BILLING;**150,158,156,186,308,563,676**;21-MAR-94;Build 34
;;Per VA Directive 6402, this routine should not be modified.
;
TRACK(DFN) ; checks out patient if tracked already
;
I '$D(^IBAM(354.7,DFN,0)) D QUERY(DFN,$E(DT,1,5)_"00")
Q
;
QUERY(DFN,IBDT) ; if there are treating facilities, perform query
N IBT,IBX,IBS,IBD,IBB,DIE,DA,DR,X,IBA,IBP,IBZ,IBY,IBFD,IBTD
S IBB=0,IBP=$$PRIORITY^IBARXMU(DFN)
;
D ADD^IBARXMU(DFN) Q:'IBP
S IBT=$$TFL^IBARXMU(DFN,.IBT,2) Q:'IBT
D CAP^IBARXMC(IBDT,IBP,.IBZ,.IBY,.IBFD,.IBTD) I 'IBY,'IBZ Q
I 'IBFD!('IBTD) Q
W !!,"This patient has never had billing information tracked before",!,"Now querying other facilities..."
S IBX=0 F S IBX=$O(IBT(IBX)) Q:IBX<1 W !,"Now sending query to ",$P(IBT(IBX),"^",2)," ..." D
. ;
. ;676;BL; Need to check for Cerner, if found send to IBARXCQR and quit
. I $P(IBT(IBX),"^",1)["200CRNR" D Q
. . D EN^IBARXCQR(DFN,$E(IBDT,1,5)_"00")
. ;
. ; need to query every month in the cap billing period
. S IBDT=IBFD D F S IBDT=$$NEXTMO^IBARXMC(IBDT) Q:IBDT>IBTD D
.. D UQUERY^IBARXMU(DFN,$E(IBDT,1,5)_"00",IBX,.IBD)
.. ;
.. ; error returned
.. I -1=+$G(IBD,"-1") Q
.. ;
.. ; loop through query and file data
.. S X=0 F S X=$O(IBD(X)) Q:X<1 S:$E(IBD(X),1,4)=(+IBT(IBX)_"-") IBA=$$ADD(DFN,IBD(X)),IBB=IBB+$P(IBD(X),"^",11)
.. K IBD
;
Q
;
ACCT(DFN,IBB,IBU,IBDT,IBS) ; - update amount in patient account
; IBB = amount to be added to pt account (billed)
; IBU = amount to be added to pt account (not billable)
; IBDT = effective date for amount
; IBS = flag, if passed the amounts are totals not to be added to what is already there
;
N DIE,DR,DO,DIC,DA,Y,IBA
;
S DA(1)=DFN,IBDT=$E(IBDT,1,5)_"00"
;
; check to see if there is already that mo/year there and add if not
S DA=$O(^IBAM(354.7,DFN,1,"B",IBDT,0))
I 'DA S DIC="^IBAM(354.7,"_DFN_",1,",DIC(0)="",X=IBDT D FILE^DICN S DA=+Y
;
; now edit and add the new amount
S IBA=^IBAM(354.7,DFN,1,DA,0)
S:'$D(IBS) IBB=IBB+$P(IBA,"^",2),IBU=IBU+$P(IBA,"^",4)
L +^IBAM(354.7,DFN):10 I '$T Q
S DIE="^IBAM(354.7,"_DFN_",1,",DR=".02///^S X=IBB;.04///^S X=IBU"
D ^DIE L -^IBAM(354.7,DFN)
;
D FLAG^IBARXMC(DFN,IBDT)
;
Q
;
UPCHG(IBX,IBU,IBC) ; update a charge (from one that is on hold only)
; IBX = ien in 354.71
; IBU = updated # of units
; IBC = updated charge amount
N IBO,IBY,DIE,DA,DR
W !,"Updating copay cap account records..."
S IBO=^IBAM(354.71,IBX,0)
;
; first update 354.71 entry
S DIE="^IBAM(354.71,",DA=IBX,DR=".07///^S X=IBU;.08///^S X=IBC;.11///^S X=IBC;.05///P"
L +^IBAM(354.71,DA):10 I '$T W !!,"Unable to update records, entry locked!!" Q
D ^DIE L -^IBAM(354.71,DA)
;
; now update account
D ACCT($P(IBO,"^",2),IBC-$P(IBO,"^",11),0,$P(IBO,"^",3))
;
; finally clean transmission record
D CLEAN(IBX)
;
Q
CLEAN(IBX) ; clean out transmission record
N IBA,DA,DIK,X,Y
S IBA=0 F S IBA=$O(^IBAM(354.71,IBX,1,IBA)) Q:IBA<1 S DA=IBA,DA(1)=IBX,DIK="^IBAM(354.71,"_IBX_",1," D ^DIK
Q
;
CANCEL(DFN,IBX,IBY,IBR) ; cancel a transaction (flags old one and creates a new one)
; IBX is the ien from 354.71, IBY is the error flag (y) passed by ref
; IBR is optional, it is the reason to cancel
;
N IBN,IBD,DIE,DA,DR,X,Y
;
; is IBX there or is this an old transaction
S IBD=$G(^IBAM(354.71,+IBX,0)) I 'IBD S IBN=0 G CANQ
S IBAMP=$P($G(^IBAM(354.71,+$P(IBD,"^",10),0)),"^")
;
; set flag for at or above cap
S:'$D(IBCAP) IBCAP=+$P($G(^IBAM(354.7,DFN,1,+$O(^IBAM(354.7,DFN,1,"B",$E($P(IBD,"^",3),1,5)_"00",0)),0)),"^",3)
;
; flag old one as canceled, and clean out transmission record.
S DIE="^IBAM(354.71,",DA=IBX,DR=".05///Y;.16///"_DUZ_";.17///"_$$NOW^XLFDT_";.19///"_$S($D(IBR):IBR,1:16)
L +^IBAM(354.71,IBX):5 I '$T S IBY="-1^IB318",IBN=0 G CANQ
D ^DIE L -^IBAM(354.71,IBX)
D CLEAN(IBX)
;
; now create new transaction to adjust amounts
; first set up parent, clear out .01, set facility, - dollar amt, status
S $P(IBD,"^",10)=$P(IBD,"^"),$P(IBD,"^")="",$P(IBD,"^",13)=+$P($$FAC^IBARXMU(+$$SITE^IBARXMU),"^",2),$P(IBD,"^",11)=-$P(IBD,"^",11),$P(IBD,"^",12)=-$P(IBD,"^",12),$P(IBD,"^",5)="P"
S IBN=$$ADD(DFN,$P(IBD,"^",1,13)_"^^^^^^^"_$P(IBD,"^",20)) I IBN<1 S IBY="-1^IB316"
;
; set up variable to check for cap and re-bill if necessary
S IBCAP($E($P(IBD,"^",3),1,5)_"00")=""
;
; now check to see if the patient has previously reached cap and has some unbilled (only if not updating, check for flag)
;I '$G(IBUPDATE) D CANCEL^IBARXMC(DFN,$P(IBD,"^",3))
;D CANCEL^IBARXMC(DFN,$P(IBD,"^",3))
;
CANQ Q IBN
;
ADD(DFN,IBD,IBT,IBPFSS) ; adds a transaction to 354.71
; IBD = data in 354.71 format, if $p(IBD,"^")="" create new number
; IBT = action type pointer (optional, but needed for local site)
; returns ien in 354.71
; IBPFSS optional to indicate came from PFSS system
;
N IBA,DIC,X,IBS,IBN,NEW
S NEW=0
Q:'$G(DFN)
D ADD^IBARXMU(DFN)
I $P(IBD,"^") S IBA=$O(^IBAM(354.71,"B",$P(IBD,"^"),0)) D Q IBA
. ;I IBA D TRANF(DFN,IBA,IBD,$G(IBT)) Q
. I 'IBA S DIC="^IBAM(354.71,",DIC(0)="",X=$P(IBD,"^") D FILE^DICN S IBA=+Y,NEW=1
. I IBA>0 D TRANF(DFN,IBA,IBD,$G(IBT)) I NEW D ACCT(DFN,$P(IBD,"^",11),$P(IBD,"^",12),$P(IBD,"^",3))
K DO S DIC="^IBAM(354.71,",DIC(0)="",IBS=+$P($$SITE^IBARXMU,"^",3)
;
; get next number and file
F L +^IBAM(354.71,0):20 I $T S IBN=$P(^IBAM(354.71,0),"^",3) S:'IBN IBN=0 Q
I +$G(^IBAM(354.71,+IBN,0))'=IBS,IBN F S IBN=$O(^IBAM(354.71,IBN),-1) Q:IBS=+$G(^IBAM(354.71,IBN,0))!('IBN)
S IBN=$P($P($G(^IBAM(354.71,+IBN,0)),"^"),"-",2)+1 F IBN=IBN:1 S X=IBS_"-"_IBN I '$D(^IBAM(354.71,"B",X)) L +^IBAM(354.71,"B",X):10 I $T D FILE^DICN L -^IBAM(354.71,"B",X) I Y>0 S IBA=+Y Q
L -^IBAM(354.71,0)
;
D TRANF(DFN,IBA,IBD,$G(IBT),$G(IBPFSS)),ACCT(DFN,$P(IBD,"^",11),$P(IBD,"^",12),$P(IBD,"^",3))
;I '$G(IBUPDATE) D CANCEL^IBARXMC(DFN,$P(IBD,"^",3))
;
Q IBA
;
TRANF(DFN,IBA,IBD,IBT,IBPFSS) ; file transaction data in 354.71
; DFN = patient's dfn
; IBA = ien from file 354.71
; IBD = data in global file format for file 354.71
; piece 2 will be changed to dfn
; pieces 10 and 13 will be resolved
; pieces 14,15 will be created new if they don't exist
; pieces 16,17 will be created new
; piece 18 will be filled if not $g(IBT)=""
;
N X,Y,IBZ,IBN,D,IBU,DIC,IBPAR,DA,DIK Q:'$D(^IBAM(354.71,IBA,0))
;
X $S($P(IBD,"^")=$P(IBD,"^",10):"S $P(IBD,""^"",10)=IBA",1:"S X=$P(IBD,""^"",10),D=""B"",DIC=""^IBAM(354.71,"",DIC(0)=""OX"" D IX^DIC S $P(IBD,""^"",10)=$S(Y>0:+Y,1:"""")")
S IBPAR=$$PARENT^IBARXMC(+$P(IBD,"^",10)) S:IBPAR $P(IBD,"^",10)=IBPAR
S DIC="^DIC(4,",DIC(0)="O",X=$P(IBD,"^",13),D="D" D IX^DIC
S IBS=$S(Y>0:+Y,1:"")
S IBN=$$NOW^XLFDT,IBU=$P(^IBAM(354.71,IBA,0),"^",14,15)
;
S $P(^IBAM(354.71,IBA,0),"^",2,18)=DFN_"^"_$P(IBD,"^",3,12)_"^"_IBS_"^"_$S(+IBU:+IBU,$D(IBDUZ):IBDUZ,1:DUZ)_"^"_$S($P(IBU,"^",2):$P(IBU,"^",2),1:IBN)_"^"_$S($D(IBDUZ):IBDUZ,1:DUZ)_"^"_IBN_$S($G(IBT):"^"_IBT,1:"")
S:$P(IBD,"^",20) $P(^IBAM(354.71,IBA,0),"^",20)=$P(IBD,"^",20)
S DA=IBA,DIK="^IBAM(354.71," D IX^DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXMN 7217 printed Dec 13, 2024@02:07:34 Page 2
IBARXMN ;LL/ELZ-PHARMCAY COPAY CAP RX PROCESSING ; 15 Jun 2021 11:46 AM
+1 ;;2.0;INTEGRATED BILLING;**150,158,156,186,308,563,676**;21-MAR-94;Build 34
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
TRACK(DFN) ; checks out patient if tracked already
+1 ;
+2 IF '$DATA(^IBAM(354.7,DFN,0))
DO QUERY(DFN,$EXTRACT(DT,1,5)_"00")
+3 QUIT
+4 ;
QUERY(DFN,IBDT) ; if there are treating facilities, perform query
+1 NEW IBT,IBX,IBS,IBD,IBB,DIE,DA,DR,X,IBA,IBP,IBZ,IBY,IBFD,IBTD
+2 SET IBB=0
SET IBP=$$PRIORITY^IBARXMU(DFN)
+3 ;
+4 DO ADD^IBARXMU(DFN)
if 'IBP
QUIT
+5 SET IBT=$$TFL^IBARXMU(DFN,.IBT,2)
if 'IBT
QUIT
+6 DO CAP^IBARXMC(IBDT,IBP,.IBZ,.IBY,.IBFD,.IBTD)
IF 'IBY
IF 'IBZ
QUIT
+7 IF 'IBFD!('IBTD)
QUIT
+8 WRITE !!,"This patient has never had billing information tracked before",!,"Now querying other facilities..."
+9 SET IBX=0
FOR
SET IBX=$ORDER(IBT(IBX))
if IBX<1
QUIT
WRITE !,"Now sending query to ",$PIECE(IBT(IBX),"^",2)," ..."
Begin DoDot:1
+10 ;
+11 ;676;BL; Need to check for Cerner, if found send to IBARXCQR and quit
+12 IF $PIECE(IBT(IBX),"^",1)["200CRNR"
Begin DoDot:2
+13 DO EN^IBARXCQR(DFN,$EXTRACT(IBDT,1,5)_"00")
End DoDot:2
QUIT
+14 ;
+15 ; need to query every month in the cap billing period
+16 SET IBDT=IBFD
Begin DoDot:2
+17 DO UQUERY^IBARXMU(DFN,$EXTRACT(IBDT,1,5)_"00",IBX,.IBD)
+18 ;
+19 ; error returned
+20 IF -1=+$GET(IBD,"-1")
QUIT
+21 ;
+22 ; loop through query and file data
+23 SET X=0
FOR
SET X=$ORDER(IBD(X))
if X<1
QUIT
if $EXTRACT(IBD(X),1,4)=(+IBT(IBX)_"-")
SET IBA=$$ADD(DFN,IBD(X))
SET IBB=IBB+$PIECE(IBD(X),"^",11)
+24 KILL IBD
End DoDot:2
FOR
SET IBDT=$$NEXTMO^IBARXMC(IBDT)
if IBDT>IBTD
QUIT
Begin DoDot:2
End DoDot:2
End DoDot:1
+25 ;
+26 QUIT
+27 ;
ACCT(DFN,IBB,IBU,IBDT,IBS) ; - update amount in patient account
+1 ; IBB = amount to be added to pt account (billed)
+2 ; IBU = amount to be added to pt account (not billable)
+3 ; IBDT = effective date for amount
+4 ; IBS = flag, if passed the amounts are totals not to be added to what is already there
+5 ;
+6 NEW DIE,DR,DO,DIC,DA,Y,IBA
+7 ;
+8 SET DA(1)=DFN
SET IBDT=$EXTRACT(IBDT,1,5)_"00"
+9 ;
+10 ; check to see if there is already that mo/year there and add if not
+11 SET DA=$ORDER(^IBAM(354.7,DFN,1,"B",IBDT,0))
+12 IF 'DA
SET DIC="^IBAM(354.7,"_DFN_",1,"
SET DIC(0)=""
SET X=IBDT
DO FILE^DICN
SET DA=+Y
+13 ;
+14 ; now edit and add the new amount
+15 SET IBA=^IBAM(354.7,DFN,1,DA,0)
+16 if '$DATA(IBS)
SET IBB=IBB+$PIECE(IBA,"^",2)
SET IBU=IBU+$PIECE(IBA,"^",4)
+17 LOCK +^IBAM(354.7,DFN):10
IF '$TEST
QUIT
+18 SET DIE="^IBAM(354.7,"_DFN_",1,"
SET DR=".02///^S X=IBB;.04///^S X=IBU"
+19 DO ^DIE
LOCK -^IBAM(354.7,DFN)
+20 ;
+21 DO FLAG^IBARXMC(DFN,IBDT)
+22 ;
+23 QUIT
+24 ;
UPCHG(IBX,IBU,IBC) ; update a charge (from one that is on hold only)
+1 ; IBX = ien in 354.71
+2 ; IBU = updated # of units
+3 ; IBC = updated charge amount
+4 NEW IBO,IBY,DIE,DA,DR
+5 WRITE !,"Updating copay cap account records..."
+6 SET IBO=^IBAM(354.71,IBX,0)
+7 ;
+8 ; first update 354.71 entry
+9 SET DIE="^IBAM(354.71,"
SET DA=IBX
SET DR=".07///^S X=IBU;.08///^S X=IBC;.11///^S X=IBC;.05///P"
+10 LOCK +^IBAM(354.71,DA):10
IF '$TEST
WRITE !!,"Unable to update records, entry locked!!"
QUIT
+11 DO ^DIE
LOCK -^IBAM(354.71,DA)
+12 ;
+13 ; now update account
+14 DO ACCT($PIECE(IBO,"^",2),IBC-$PIECE(IBO,"^",11),0,$PIECE(IBO,"^",3))
+15 ;
+16 ; finally clean transmission record
+17 DO CLEAN(IBX)
+18 ;
+19 QUIT
CLEAN(IBX) ; clean out transmission record
+1 NEW IBA,DA,DIK,X,Y
+2 SET IBA=0
FOR
SET IBA=$ORDER(^IBAM(354.71,IBX,1,IBA))
if IBA<1
QUIT
SET DA=IBA
SET DA(1)=IBX
SET DIK="^IBAM(354.71,"_IBX_",1,"
DO ^DIK
+3 QUIT
+4 ;
CANCEL(DFN,IBX,IBY,IBR) ; cancel a transaction (flags old one and creates a new one)
+1 ; IBX is the ien from 354.71, IBY is the error flag (y) passed by ref
+2 ; IBR is optional, it is the reason to cancel
+3 ;
+4 NEW IBN,IBD,DIE,DA,DR,X,Y
+5 ;
+6 ; is IBX there or is this an old transaction
+7 SET IBD=$GET(^IBAM(354.71,+IBX,0))
IF 'IBD
SET IBN=0
GOTO CANQ
+8 SET IBAMP=$PIECE($GET(^IBAM(354.71,+$PIECE(IBD,"^",10),0)),"^")
+9 ;
+10 ; set flag for at or above cap
+11 if '$DATA(IBCAP)
SET IBCAP=+$PIECE($GET(^IBAM(354.7,DFN,1,+$ORDER(^IBAM(354.7,DFN,1,"B",$EXTRACT($PIECE(IBD,"^",3),1,5)_"00",0)),0)),"^",3)
+12 ;
+13 ; flag old one as canceled, and clean out transmission record.
+14 SET DIE="^IBAM(354.71,"
SET DA=IBX
SET DR=".05///Y;.16///"_DUZ_";.17///"_$$NOW^XLFDT_";.19///"_$S($DATA(IBR):IBR,1:16)
+15 LOCK +^IBAM(354.71,IBX):5
IF '$TEST
SET IBY="-1^IB318"
SET IBN=0
GOTO CANQ
+16 DO ^DIE
LOCK -^IBAM(354.71,IBX)
+17 DO CLEAN(IBX)
+18 ;
+19 ; now create new transaction to adjust amounts
+20 ; first set up parent, clear out .01, set facility, - dollar amt, status
+21 SET $PIECE(IBD,"^",10)=$PIECE(IBD,"^")
SET $PIECE(IBD,"^")=""
SET $PIECE(IBD,"^",13)=+$PIECE($$FAC^IBARXMU(+$$SITE^IBARXMU),"^",2)
SET $PIECE(IBD,"^",11)=-$PIECE(IBD,"^",11)
SET $PIECE(IBD,"^",12)=-$PIECE(IBD,"^",12)
SET $PIECE(IBD,"^",5)="P"
+22 SET IBN=$$ADD(DFN,$PIECE(IBD,"^",1,13)_"^^^^^^^"_$PIECE(IBD,"^",20))
IF IBN<1
SET IBY="-1^IB316"
+23 ;
+24 ; set up variable to check for cap and re-bill if necessary
+25 SET IBCAP($EXTRACT($PIECE(IBD,"^",3),1,5)_"00")=""
+26 ;
+27 ; now check to see if the patient has previously reached cap and has some unbilled (only if not updating, check for flag)
+28 ;I '$G(IBUPDATE) D CANCEL^IBARXMC(DFN,$P(IBD,"^",3))
+29 ;D CANCEL^IBARXMC(DFN,$P(IBD,"^",3))
+30 ;
CANQ QUIT IBN
+1 ;
ADD(DFN,IBD,IBT,IBPFSS) ; adds a transaction to 354.71
+1 ; IBD = data in 354.71 format, if $p(IBD,"^")="" create new number
+2 ; IBT = action type pointer (optional, but needed for local site)
+3 ; returns ien in 354.71
+4 ; IBPFSS optional to indicate came from PFSS system
+5 ;
+6 NEW IBA,DIC,X,IBS,IBN,NEW
+7 SET NEW=0
+8 if '$GET(DFN)
QUIT
+9 DO ADD^IBARXMU(DFN)
+10 IF $PIECE(IBD,"^")
SET IBA=$ORDER(^IBAM(354.71,"B",$PIECE(IBD,"^"),0))
Begin DoDot:1
+11 ;I IBA D TRANF(DFN,IBA,IBD,$G(IBT)) Q
+12 IF 'IBA
SET DIC="^IBAM(354.71,"
SET DIC(0)=""
SET X=$PIECE(IBD,"^")
DO FILE^DICN
SET IBA=+Y
SET NEW=1
+13 IF IBA>0
DO TRANF(DFN,IBA,IBD,$GET(IBT))
IF NEW
DO ACCT(DFN,$PIECE(IBD,"^",11),$PIECE(IBD,"^",12),$PIECE(IBD,"^",3))
End DoDot:1
QUIT IBA
+14 KILL DO
SET DIC="^IBAM(354.71,"
SET DIC(0)=""
SET IBS=+$PIECE($$SITE^IBARXMU,"^",3)
+15 ;
+16 ; get next number and file
+17 FOR
LOCK +^IBAM(354.71,0):20
IF $TEST
SET IBN=$PIECE(^IBAM(354.71,0),"^",3)
if 'IBN
SET IBN=0
QUIT
+18 IF +$GET(^IBAM(354.71,+IBN,0))'=IBS
IF IBN
FOR
SET IBN=$ORDER(^IBAM(354.71,IBN),-1)
if IBS=+$GET(^IBAM(354.71,IBN,0))!('IBN)
QUIT
+19 SET IBN=$PIECE($PIECE($GET(^IBAM(354.71,+IBN,0)),"^"),"-",2)+1
FOR IBN=IBN:1
SET X=IBS_"-"_IBN
IF '$DATA(^IBAM(354.71,"B",X))
LOCK +^IBAM(354.71,"B",X):10
IF $TEST
DO FILE^DICN
LOCK -^IBAM(354.71,"B",X)
IF Y>0
SET IBA=+Y
QUIT
+20 LOCK -^IBAM(354.71,0)
+21 ;
+22 DO TRANF(DFN,IBA,IBD,$GET(IBT),$GET(IBPFSS))
DO ACCT(DFN,$PIECE(IBD,"^",11),$PIECE(IBD,"^",12),$PIECE(IBD,"^",3))
+23 ;I '$G(IBUPDATE) D CANCEL^IBARXMC(DFN,$P(IBD,"^",3))
+24 ;
+25 QUIT IBA
+26 ;
TRANF(DFN,IBA,IBD,IBT,IBPFSS) ; file transaction data in 354.71
+1 ; DFN = patient's dfn
+2 ; IBA = ien from file 354.71
+3 ; IBD = data in global file format for file 354.71
+4 ; piece 2 will be changed to dfn
+5 ; pieces 10 and 13 will be resolved
+6 ; pieces 14,15 will be created new if they don't exist
+7 ; pieces 16,17 will be created new
+8 ; piece 18 will be filled if not $g(IBT)=""
+9 ;
+10 NEW X,Y,IBZ,IBN,D,IBU,DIC,IBPAR,DA,DIK
if '$DATA(^IBAM(354.71,IBA,0))
QUIT
+11 ;
+12 XECUTE $SELECT($PIECE(IBD,"^")=$PIECE(IBD,"^",10):"S $P(IBD,""^"",10)=IBA",1:"S X=$P(IBD,""^"",10),D=""B"",DIC=""^IBAM(354.71,"",DIC(0)=""OX"" D IX^DIC S $P(IBD,""^"",10)=$S(Y>0:+Y,1:"""")")
+13 SET IBPAR=$$PARENT^IBARXMC(+$PIECE(IBD,"^",10))
if IBPAR
SET $PIECE(IBD,"^",10)=IBPAR
+14 SET DIC="^DIC(4,"
SET DIC(0)="O"
SET X=$PIECE(IBD,"^",13)
SET D="D"
DO IX^DIC
+15 SET IBS=$SELECT(Y>0:+Y,1:"")
+16 SET IBN=$$NOW^XLFDT
SET IBU=$PIECE(^IBAM(354.71,IBA,0),"^",14,15)
+17 ;
+18 SET $PIECE(^IBAM(354.71,IBA,0),"^",2,18)=DFN_"^"_$PIECE(IBD,"^",3,12)_"^"_IBS_"^"_$SELECT(+IBU:+IBU,$DATA(IBDUZ):IBDUZ,1:DUZ)_"^"_$SELECT($PIECE(IBU,"^",2):$PIECE(IBU,"^",2),1:IBN)_"^"_$SELECT($DATA(IBDUZ):IBDUZ,1:DUZ)_"^"_IBN_...
... $SELECT($GET(IBT):"^"_IBT,1:"")
+19 if $PIECE(IBD,"^",20)
SET $PIECE(^IBAM(354.71,IBA,0),"^",20)=$PIECE(IBD,"^",20)
+20 SET DA=IBA
SET DIK="^IBAM(354.71,"
DO IX^DIK
+21 QUIT
