- 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 Jan 18, 2025@03:08:47 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