IB20PT62 ;ALB/AAS - Insurance post init stuff ; 2/22/93
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;
W:'$D(ZTQUEUED) !!," I'll write a dot for each 100 entries"
;
N IBTRNSF S IBTRNSF=0 I $O(^IBA(362.2,0)) S IBTRNSF=1 D DQ362
;
DQ399 D NOW^%DTC S IBSCDT=%
N IBCIFN
W:'$D(ZTQUEUED) !!," Updating Bill/Claims file"
S (IBCIFN,IBCNT,IBCNTD)=0
F S IBCIFN=$O(^DGCR(399,IBCIFN)) Q:'IBCIFN D
.I +$G(^DGCR(399,IBCIFN,"M")),$P($G(^(0)),"^",2) S ^DGCR(399,"AE",$P(^(0),"^",2),+^("M"),IBCIFN)=""
.I +$P($G(^DGCR(399,IBCIFN,0)),U,13)=3 S ^DGCR(399,"AST",3,IBCIFN)=""
.I '$G(IBTRNSF),$D(^DGCR(399,IBCIFN,"C")) D MVDX
.I +$P($G(^DGCR(399,IBCIFN,0)),U,19)>1 D DXCPTCV
.S IBCNT=$G(IBCNT)+1 I '$D(ZTQUEUED) W:'(IBCNT#100) "."
S $P(^IBE(350.9,1,3),"^",19)=DT
D NOW^%DTC S IBECDT=%
I '$D(ZTQUEUED) W !," Completed!"
Q
;
DQ362 ;transfer entries from 362.2 to 362.3
N IBDIFN,IBD,IBCIFN,IBDX,IBP,IBDA,IBCNT
I '$D(ZTQUEUED) W !!," Moving diagnosis to new file"
S IBCNT=0,IBDIFN=0 F S IBDIFN=$O(^IBA(362.2,IBDIFN)) Q:'IBDIFN D
.S IBD=$G(^IBA(362.2,IBDIFN,0))
.S IBCIFN=+IBD,IBDX=+$P(IBD,U,2),IBP=$P(IBD,U,3)
.I +IBCIFN,+IBDX D SETDX
.S IBCNT=IBCNT+1 I '$D(ZTQUEUED),'(IBCNT#100) W "."
S DIU="^IBA(362.2,",DIU(0)="D" D EN^DIU2 K DIU
I '$D(ZTQUEUED) W " Completed!"
Q
;
DXCPTCV ;transfer/convert associated dx (399,304,7->399,304,10)
N IBCP,IBDX,IBDXP
L +^DGCR(399,IBCIFN)
S IBCP=0 F S IBCP=$O(^DGCR(399,IBCIFN,"CP",IBCP)) Q:'IBCP D
. S IBDX=+$P($G(^DGCR(399,IBCIFN,"CP",IBCP,0)),U,8) Q:'IBDX
. S IBDXP=$O(^IBA(362.3,"AIFN"_IBCIFN,IBDX,0)) Q:'IBDXP
. S $P(^DGCR(399,IBCIFN,"CP",IBCP,0),U,11)=IBDXP
L -^DGCR(399,IBCIFN)
Q
;
MVDX ; -- move procedures from file 399 fields 64-68 to new file 362.2
;
N IBC,IBDA,IBDX,IBP
S IBC=$G(^DGCR(399,IBCIFN,"C"))
F IBP=14:1:18 S IBDX=$P(IBC,"^",IBP) I IBDX D SETDX
Q
;
SETDX Q:$D(^IBA(362.3,"AIFN"_IBCIFN,IBDX)) ; same diag for a bill not allowed
L +^IBA(362.3,0):10 Q:'$T
S IBDA=$P($G(^IBA(362.3,0)),"^",3)+1
L -^IBA(362.3,0)
F IBDA=IBDA:1 I '$D(^IBA(362.3,IBDA,0)) L +^IBA(362.3,IBDA) Q
S ^IBA(362.3,IBDA,0)=IBDX_"^"_IBCIFN_"^"_IBP
S ^IBA(362.3,"B",IBDX,IBDA)=""
S ^IBA(362.3,"AIFN"_IBCIFN,IBDX,IBDA)=""
I +IBP S ^IBA(362.3,"AO",IBCIFN,IBP,IBDA)=""
L -^IBA(362.3,IBDA)
L +^IBA(362.3,0):10
S $P(^IBA(362.3,0),"^",4)=$P(^IBA(362.3,0),"^",3)+1
S $P(^IBA(362.3,0),"^",3)=IBDA
L -^IBA(362.3,0)
S IBCNTD=$G(IBCNTD)+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20PT62 2474 printed Dec 13, 2024@02:05:24 Page 2
IB20PT62 ;ALB/AAS - Insurance post init stuff ; 2/22/93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;
+3 if '$DATA(ZTQUEUED)
WRITE !!," I'll write a dot for each 100 entries"
+4 ;
+5 NEW IBTRNSF
SET IBTRNSF=0
IF $ORDER(^IBA(362.2,0))
SET IBTRNSF=1
DO DQ362
+6 ;
DQ399 DO NOW^%DTC
SET IBSCDT=%
+1 NEW IBCIFN
+2 if '$DATA(ZTQUEUED)
WRITE !!," Updating Bill/Claims file"
+3 SET (IBCIFN,IBCNT,IBCNTD)=0
+4 FOR
SET IBCIFN=$ORDER(^DGCR(399,IBCIFN))
if 'IBCIFN
QUIT
Begin DoDot:1
+5 IF +$GET(^DGCR(399,IBCIFN,"M"))
IF $PIECE($GET(^(0)),"^",2)
SET ^DGCR(399,"AE",$PIECE(^(0),"^",2),+^("M"),IBCIFN)=""
+6 IF +$PIECE($GET(^DGCR(399,IBCIFN,0)),U,13)=3
SET ^DGCR(399,"AST",3,IBCIFN)=""
+7 IF '$GET(IBTRNSF)
IF $DATA(^DGCR(399,IBCIFN,"C"))
DO MVDX
+8 IF +$PIECE($GET(^DGCR(399,IBCIFN,0)),U,19)>1
DO DXCPTCV
+9 SET IBCNT=$GET(IBCNT)+1
IF '$DATA(ZTQUEUED)
if '(IBCNT#100)
WRITE "."
End DoDot:1
+10 SET $PIECE(^IBE(350.9,1,3),"^",19)=DT
+11 DO NOW^%DTC
SET IBECDT=%
+12 IF '$DATA(ZTQUEUED)
WRITE !," Completed!"
+13 QUIT
+14 ;
DQ362 ;transfer entries from 362.2 to 362.3
+1 NEW IBDIFN,IBD,IBCIFN,IBDX,IBP,IBDA,IBCNT
+2 IF '$DATA(ZTQUEUED)
WRITE !!," Moving diagnosis to new file"
+3 SET IBCNT=0
SET IBDIFN=0
FOR
SET IBDIFN=$ORDER(^IBA(362.2,IBDIFN))
if 'IBDIFN
QUIT
Begin DoDot:1
+4 SET IBD=$GET(^IBA(362.2,IBDIFN,0))
+5 SET IBCIFN=+IBD
SET IBDX=+$PIECE(IBD,U,2)
SET IBP=$PIECE(IBD,U,3)
+6 IF +IBCIFN
IF +IBDX
DO SETDX
+7 SET IBCNT=IBCNT+1
IF '$DATA(ZTQUEUED)
IF '(IBCNT#100)
WRITE "."
End DoDot:1
+8 SET DIU="^IBA(362.2,"
SET DIU(0)="D"
DO EN^DIU2
KILL DIU
+9 IF '$DATA(ZTQUEUED)
WRITE " Completed!"
+10 QUIT
+11 ;
DXCPTCV ;transfer/convert associated dx (399,304,7->399,304,10)
+1 NEW IBCP,IBDX,IBDXP
+2 LOCK +^DGCR(399,IBCIFN)
+3 SET IBCP=0
FOR
SET IBCP=$ORDER(^DGCR(399,IBCIFN,"CP",IBCP))
if 'IBCP
QUIT
Begin DoDot:1
+4 SET IBDX=+$PIECE($GET(^DGCR(399,IBCIFN,"CP",IBCP,0)),U,8)
if 'IBDX
QUIT
+5 SET IBDXP=$ORDER(^IBA(362.3,"AIFN"_IBCIFN,IBDX,0))
if 'IBDXP
QUIT
+6 SET $PIECE(^DGCR(399,IBCIFN,"CP",IBCP,0),U,11)=IBDXP
End DoDot:1
+7 LOCK -^DGCR(399,IBCIFN)
+8 QUIT
+9 ;
MVDX ; -- move procedures from file 399 fields 64-68 to new file 362.2
+1 ;
+2 NEW IBC,IBDA,IBDX,IBP
+3 SET IBC=$GET(^DGCR(399,IBCIFN,"C"))
+4 FOR IBP=14:1:18
SET IBDX=$PIECE(IBC,"^",IBP)
IF IBDX
DO SETDX
+5 QUIT
+6 ;
SETDX ; same diag for a bill not allowed
if $DATA(^IBA(362.3,"AIFN"_IBCIFN,IBDX))
QUIT
+1 LOCK +^IBA(362.3,0):10
if '$TEST
QUIT
+2 SET IBDA=$PIECE($GET(^IBA(362.3,0)),"^",3)+1
+3 LOCK -^IBA(362.3,0)
+4 FOR IBDA=IBDA:1
IF '$DATA(^IBA(362.3,IBDA,0))
LOCK +^IBA(362.3,IBDA)
QUIT
+5 SET ^IBA(362.3,IBDA,0)=IBDX_"^"_IBCIFN_"^"_IBP
+6 SET ^IBA(362.3,"B",IBDX,IBDA)=""
+7 SET ^IBA(362.3,"AIFN"_IBCIFN,IBDX,IBDA)=""
+8 IF +IBP
SET ^IBA(362.3,"AO",IBCIFN,IBP,IBDA)=""
+9 LOCK -^IBA(362.3,IBDA)
+10 LOCK +^IBA(362.3,0):10
+11 SET $PIECE(^IBA(362.3,0),"^",4)=$PIECE(^IBA(362.3,0),"^",3)+1
+12 SET $PIECE(^IBA(362.3,0),"^",3)=IBDA
+13 LOCK -^IBA(362.3,0)
+14 SET IBCNTD=$GET(IBCNTD)+1
+15 QUIT
