- IBCD3 ;ALB/ARH - AUTOMATED BILLER (ADD NEW BILL - CREATE BILL ENTRY) ; 9/5/93
- ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- ;
- N IBI,IBX,IBY,I,X,IBAC K IBDR S IBAC=1
- S X=$P($T(WHERE),";;",2) F I=0:0 S I=$O(IB(I)) Q:'I S X1=$P($E(X,$F(X,I)+1,999),";",1) I $D(IB(I))=1 S $P(IBDR($P(X1,"^",1)),"^",$P(X1,"^",2))=IB(I)
- F I=0,"C","M","M1","S","U","U1" I $D(IBDR(I)) S ^DGCR(399,IBIFN,I)=IBDR(I)
- S $P(^DGCR(399,0),"^",3)=IBIFN,$P(^(0),"^",4)=$P(^(0),"^",4)+1
- S DIK="^DGCR(399,",DA=IBIFN D IX1^DIK K DA,DIK ; set cross-references
- ;
- RX ; file rx refills, add default CPT and Dx if defined
- I $D(IB(362.4))>2 D G END
- . S IBRX=0 F S IBRX=$O(IB(362.4,IBRX)) Q:'IBRX S IBY=0 F S IBY=$O(IB(362.4,IBRX,IBY)) Q:'IBY D
- .. S IBX=IB(362.4,IBRX,IBY) Q:IBX=""
- .. S DIC="^IBA(362.4,",DIC(0)="L",X=$P(IBX,U,1) K DD,DO D FILE^DICN K DA,DINUM,DO,DD
- .. I Y>0 S DIE=DIC,DA=+Y,DR=".02////"_IBIFN_";.03////"_$P(IBX,U,4)_";.04////"_$P(IBX,U,2)_";.05////"_+IBRX_";.06////"_$P(IBX,U,3)_";.07////"_$P(IBX,U,5)_";.08////"_$P(IBX,U,6) D ^DIE K DIE,DIC,DA,DR
- . ;
- . D DEFAULT^IBCSC5C(IBIFN)
- ;
- OUTPT ;file outpatient visit dates and find/store outpatient procedures and diagnosis
- I IB(.05)>2 D G END
- . I $D(IB(43))>2 D
- .. S ^DGCR(399,IBIFN,"OP",0)="^399.043DA^" S IBX=0 F S IBX=$O(IB(43,IBX)) Q:'IBX D
- ... S DIC="^DGCR(399,"_IBIFN_",""OP"",",DIC(0)="L",DA(1)=IBIFN,(DINUM,X)=IBX K DD,DO D FILE^DICN K DIC,DA,DINUM,DO,DD
- . ;
- . D VST^IBCCPT I $D(^UTILITY($J,"CPT-CNT")) D
- .. S ^DGCR(399,IBIFN,"CP",0)="^399.0304AVI^"
- .. S IBY=0 F S IBY=$O(^UTILITY($J,"CPT-CNT",IBY)) Q:'IBY S IBX=^(IBY) D
- ... S DIC="^DGCR(399,"_IBIFN_",""CP"",",DIC(0)="L",DA(1)=IBIFN,X=+IBX_";ICPT(" K DD,DO D FILE^DICN
- ... I Y>0 S DIE=DIC,DA=+Y,DR="1////"_$P(IBX,U,2)_$S(+$P(IBX,U,4):";5////"_$P(IBX,U,5),1:"") D ^DIE K DIE,DIC,DA,DINUM,DO,DD
- . K DGCNT,V,IBOPV1,IBOPV2,I,DGDIV,I1,DGNOD,DGCPTS,I7,I2,DGCPT,^UTILITY($J,"CPT-CNT")
- . ;
- . D OPTDX^IBCSC4D(DFN,IB(151),IB(152),.IBDX) I +IBDX D K IBDX
- .. S IBY=0 F S IBY=$O(IBDX(IBY)) Q:IBY="" S IBX=IBDX(IBY) D
- ... S DIC="^IBA(362.3,",DIC(0)="L",X=+IBX K DD,DO D FILE^DICN
- ... I Y>0 S DIE=DIC,DA=+Y,DR=".02////"_IBIFN D ^DIE K DIE,DIC,DA,DINUM,DO,DD
- ;
- ;store inpatient diagnosis and procedures
- INPT I IB(.05)<3 D G END
- . I $G(^TMP("IBDX",$J))=IB(.08) D K ^TMP("IBDX",$J)
- .. S (IBI,IBX)=0 F S IBX=$O(^TMP("IBDX",$J,IBX)) Q:'IBX S IBI=IBI+1 D
- ... S DIC="^IBA(362.3,",DIC(0)="L",X=+IBX K DD,DO D FILE^DICN
- ... I Y>0 S DIE=DIC,DA=+Y,DR=".02////"_IBIFN_";.03////"_IBI D ^DIE K DIE,DIC,DA,DINUM,DO,DD
- . ;
- . D IPRC^IBCD4(+IB(.08),IB(151),IB(152)) I $D(^TMP("IBIPRC",$J)) D K ^TMP("IBIPRC",$J)
- .. S ^DGCR(399,IBIFN,"CP",0)="^399.0304AVI^"
- .. S IBX=0 F S IBX=$O(^TMP("IBIPRC",$J,IBX)) Q:'IBX D
- ... S IBY=^TMP("IBIPRC",$J,IBX) F IBI=1:1 S IBZ=$P(IBY,U,IBI) Q:'IBZ D
- .... S DIC="^DGCR(399,"_IBIFN_",""CP"",",DIC(0)="L",DA(1)=IBIFN,X=+IBZ_";ICD0(" K DD,DO D FILE^DICN
- .... I Y>0 S DIE=DIC,DA=+Y,DR="1////"_IBX D ^DIE K DIE,DIC,DA,DINUM,DO,DD
- ;
- END S IBX="1^Billing Record #"_$P(^DGCR(399,+IBIFN,0),"^",1)_" established for "_$P($G(^DPT(IBDFN,0)),U,1)
- ;
- S IBAUTO=1,DGPTUPDT="" D ^IBCU6 ; auto calculate/store revenue codes
- ;
- Q K %,%DT,IBDR,X1,X2,X3,X4,Y,DGDIRA,DGDIRB,DGDIR0,DIR,DGRVRCAL,DIC,DA,DINUM,DGPTUPDT,DGXRF1,IBCHK,IBINDT
- Q
- ;
- WHERE ;;.01^0^1;.02^0^2;.03^0^3;.04^0^4;.05^0^5;.06^0^6;.07^0^7;.08^0^8;.09^0^9;.11^0^11;.17^0^17;.16^0^16;.18^0^18;.19^0^19;.2^0^20;112^M^12;151^U^1;152^U^2;155^U^5;101^M^1;158^U^8;159^U^9;160^U^10;161^U^11;162^U^12;
- IBCD3 ;ALB/ARH - AUTOMATED BILLER (ADD NEW BILL - CREATE BILL ENTRY) ; 9/5/93
- +1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- +4 ;
- +5 NEW IBI,IBX,IBY,I,X,IBAC
- KILL IBDR
- SET IBAC=1
- +6 SET X=$PIECE($TEXT(WHERE),";;",2)
- FOR I=0:0
- SET I=$ORDER(IB(I))
- IF 'I
- QUIT
- SET X1=$PIECE($EXTRACT(X,$FIND(X,I)+1,999),";",1)
- IF $DATA(IB(I))=1
- SET $PIECE(IBDR($PIECE(X1,"^",1)),"^",$PIECE(X1,"^",2))=IB(I)
- +7 FOR I=0,"C","M","M1","S","U","U1"
- IF $DATA(IBDR(I))
- SET ^DGCR(399,IBIFN,I)=IBDR(I)
- +8 SET $PIECE(^DGCR(399,0),"^",3)=IBIFN
- SET $PIECE(^(0),"^",4)=$PIECE(^(0),"^",4)+1
- +9 ; set cross-references
- SET DIK="^DGCR(399,"
- SET DA=IBIFN
- DO IX1^DIK
- KILL DA,DIK
- +10 ;
- RX ; file rx refills, add default CPT and Dx if defined
- +1 IF $DATA(IB(362.4))>2
- Begin DoDot:1
- +2 SET IBRX=0
- FOR
- SET IBRX=$ORDER(IB(362.4,IBRX))
- IF 'IBRX
- QUIT
- SET IBY=0
- FOR
- SET IBY=$ORDER(IB(362.4,IBRX,IBY))
- IF 'IBY
- QUIT
- Begin DoDot:2
- +3 SET IBX=IB(362.4,IBRX,IBY)
- IF IBX=""
- QUIT
- +4 SET DIC="^IBA(362.4,"
- SET DIC(0)="L"
- SET X=$PIECE(IBX,U,1)
- KILL DD,DO
- DO FILE^DICN
- KILL DA,DINUM,DO,DD
- +5 IF Y>0
- SET DIE=DIC
- SET DA=+Y
- SET DR=".02////"_IBIFN_";.03////"_$PIECE(IBX,U,4)_";.04////"_$PIECE(IBX,U,2)_";.05////"_+IBRX_";.06////"_$PIECE(IBX,U,3)_";.07////"_$PIECE(IBX,U,5)_";.08////"_$PIECE(IBX,U,6)
- DO ^DIE
- KILL DIE,DIC,DA,DR
- End DoDot:2
- +6 ;
- +7 DO DEFAULT^IBCSC5C(IBIFN)
- End DoDot:1
- GOTO END
- +8 ;
- OUTPT ;file outpatient visit dates and find/store outpatient procedures and diagnosis
- +1 IF IB(.05)>2
- Begin DoDot:1
- +2 IF $DATA(IB(43))>2
- Begin DoDot:2
- +3 SET ^DGCR(399,IBIFN,"OP",0)="^399.043DA^"
- SET IBX=0
- FOR
- SET IBX=$ORDER(IB(43,IBX))
- IF 'IBX
- QUIT
- Begin DoDot:3
- +4 SET DIC="^DGCR(399,"_IBIFN_",""OP"","
- SET DIC(0)="L"
- SET DA(1)=IBIFN
- SET (DINUM,X)=IBX
- KILL DD,DO
- DO FILE^DICN
- KILL DIC,DA,DINUM,DO,DD
- End DoDot:3
- End DoDot:2
- +5 ;
- +6 DO VST^IBCCPT
- IF $DATA(^UTILITY($JOB,"CPT-CNT"))
- Begin DoDot:2
- +7 SET ^DGCR(399,IBIFN,"CP",0)="^399.0304AVI^"
- +8 SET IBY=0
- FOR
- SET IBY=$ORDER(^UTILITY($JOB,"CPT-CNT",IBY))
- IF 'IBY
- QUIT
- SET IBX=^(IBY)
- Begin DoDot:3
- +9 SET DIC="^DGCR(399,"_IBIFN_",""CP"","
- SET DIC(0)="L"
- SET DA(1)=IBIFN
- SET X=+IBX_";ICPT("
- KILL DD,DO
- DO FILE^DICN
- +10 IF Y>0
- SET DIE=DIC
- SET DA=+Y
- SET DR="1////"_$PIECE(IBX,U,2)_$SELECT(+$PIECE(IBX,U,4):";5////"_$PIECE(IBX,U,5),1:"")
- DO ^DIE
- KILL DIE,DIC,DA,DINUM,DO,DD
- End DoDot:3
- End DoDot:2
- +11 KILL DGCNT,V,IBOPV1,IBOPV2,I,DGDIV,I1,DGNOD,DGCPTS,I7,I2,DGCPT,^UTILITY($JOB,"CPT-CNT")
- +12 ;
- +13 DO OPTDX^IBCSC4D(DFN,IB(151),IB(152),.IBDX)
- IF +IBDX
- Begin DoDot:2
- +14 SET IBY=0
- FOR
- SET IBY=$ORDER(IBDX(IBY))
- IF IBY=""
- QUIT
- SET IBX=IBDX(IBY)
- Begin DoDot:3
- +15 SET DIC="^IBA(362.3,"
- SET DIC(0)="L"
- SET X=+IBX
- KILL DD,DO
- DO FILE^DICN
- +16 IF Y>0
- SET DIE=DIC
- SET DA=+Y
- SET DR=".02////"_IBIFN
- DO ^DIE
- KILL DIE,DIC,DA,DINUM,DO,DD
- End DoDot:3
- End DoDot:2
- KILL IBDX
- End DoDot:1
- GOTO END
- +17 ;
- +18 ;store inpatient diagnosis and procedures
- INPT IF IB(.05)<3
- Begin DoDot:1
- +1 IF $GET(^TMP("IBDX",$JOB))=IB(.08)
- Begin DoDot:2
- +2 SET (IBI,IBX)=0
- FOR
- SET IBX=$ORDER(^TMP("IBDX",$JOB,IBX))
- IF 'IBX
- QUIT
- SET IBI=IBI+1
- Begin DoDot:3
- +3 SET DIC="^IBA(362.3,"
- SET DIC(0)="L"
- SET X=+IBX
- KILL DD,DO
- DO FILE^DICN
- +4 IF Y>0
- SET DIE=DIC
- SET DA=+Y
- SET DR=".02////"_IBIFN_";.03////"_IBI
- DO ^DIE
- KILL DIE,DIC,DA,DINUM,DO,DD
- End DoDot:3
- End DoDot:2
- KILL ^TMP("IBDX",$JOB)
- +5 ;
- +6 DO IPRC^IBCD4(+IB(.08),IB(151),IB(152))
- IF $DATA(^TMP("IBIPRC",$JOB))
- Begin DoDot:2
- +7 SET ^DGCR(399,IBIFN,"CP",0)="^399.0304AVI^"
- +8 SET IBX=0
- FOR
- SET IBX=$ORDER(^TMP("IBIPRC",$JOB,IBX))
- IF 'IBX
- QUIT
- Begin DoDot:3
- +9 SET IBY=^TMP("IBIPRC",$JOB,IBX)
- FOR IBI=1:1
- SET IBZ=$PIECE(IBY,U,IBI)
- IF 'IBZ
- QUIT
- Begin DoDot:4
- +10 SET DIC="^DGCR(399,"_IBIFN_",""CP"","
- SET DIC(0)="L"
- SET DA(1)=IBIFN
- SET X=+IBZ_";ICD0("
- KILL DD,DO
- DO FILE^DICN
- +11 IF Y>0
- SET DIE=DIC
- SET DA=+Y
- SET DR="1////"_IBX
- DO ^DIE
- KILL DIE,DIC,DA,DINUM,DO,DD
- End DoDot:4
- End DoDot:3
- End DoDot:2
- KILL ^TMP("IBIPRC",$JOB)
- End DoDot:1
- GOTO END
- +12 ;
- END SET IBX="1^Billing Record #"_$PIECE(^DGCR(399,+IBIFN,0),"^",1)_" established for "_$PIECE($GET(^DPT(IBDFN,0)),U,1)
- +1 ;
- +2 ; auto calculate/store revenue codes
- SET IBAUTO=1
- SET DGPTUPDT=""
- DO ^IBCU6
- +3 ;
- Q KILL %,%DT,IBDR,X1,X2,X3,X4,Y,DGDIRA,DGDIRB,DGDIR0,DIR,DGRVRCAL,DIC,DA,DINUM,DGPTUPDT,DGXRF1,IBCHK,IBINDT
- +1 QUIT
- +2 ;
- WHERE ;;.01^0^1;.02^0^2;.03^0^3;.04^0^4;.05^0^5;.06^0^6;.07^0^7;.08^0^8;.09^0^9;.11^0^11;.17^0^17;.16^0^16;.18^0^18;.19^0^19;.2^0^20;112^M^12;151^U^1;152^U^2;155^U^5;101^M^1;158^U^8;159^U^9;160^U^10;161^U^11;162^U^12;
