- 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
- 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
