IBCA2 ;ALB/MRL - ADD NEW BILL ;01 JUN 88 12:00
;;2.0;INTEGRATED BILLING;**106,714**;21-MAR-94;Build 8
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;MAP TO DGCRA2
;
W !,"Passing bill to Accounts Receivable Module..." D SETUP^PRCASVC3
I $S($P(PRCASV("ARREC"),U)=-1:1,$P(PRCASV("ARBIL"),U)=-1:1,1:0) W *7," ",$P(PRCASV("ARREC"),"^",2),!,$$ETXT^IBEFUNC($P(PRCASV("ARBIL"),"^",2)) D Q G NREC^IBCA
S IBIDS(.01)=$P(PRCASV("ARBIL"),"-",2),IBIDS(.17)=$S($D(IBIDS(.17)):IBIDS(.17),1:PRCASV("ARREC"))
W !,"Billing Record #",IBIDS(.01)," being established for '",VADM(1),"'..." S IBIDS(.02)=DFN
;D SC^IBCU3 ;calculate if SC veteran
S IBIDS(.18)=$$SC^IBCU3(DFN) ; calculate if SC veteran
D SPEC^IBCU4 ;calculate discharge bedsection
S X=$P($T(WHERE),";;",2) F I=0:0 S I=$O(IBIDS(I)) Q:'I S X1=$P($E(X,$F(X,I)+1,999),";",1),$P(IBDR($P(X1,"^",1)),"^",$P(X1,"^",2))=IBIDS(I)
S IBIFN=PRCASV("ARREC") 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 W !,"Cross-referencing new billing entry..." S DIK="^DGCR(399,",DA=IBIFN D IX1^DIK K DA,DIK
S IBYN=1 W !!,*7,"Billing Record #",$P(^DGCR(399,+IBIFN,0),"^",1)," established for '",VADM(1),"'..."
K DGPTUPDT D ^IBCU6
Q K %,%DT,IBI,IBJ,IBDSDT,IBX,IB,IBA,IBNWBL,IBBT,IBIDS,I,J,VADM,X,X1,X2,X3,X4,Y,DGDIRA,DGDIRB,DGDIR0,DIR,DGRVRCAL Q
;
XREF F IBI1=0:0 S IBI1=$O(^DD(399,IBI,1,IBI1)) Q:'IBI1 I $D(^DD(399,IBI,1,IBI1,1)) S DA=IBIFN,X=IBIDS(IBI) X ^DD(399,IBI,1,IBI1,1)
Q
; IB*2.0*714 added field .28 to WHERE tag.
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;.11^0^11;.17^0^17;.16^0^16;.18^0^18;.19^0^19;.22^0^22;.27^0^27;.28^0^28;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;
;
WHEREOLD ;.01^0^1;.02^0^2;.03^0^3;.04^0^4;.05^0^5;.06^0^6;.07^0^7;.08^0^8;.11^0^11;.17^0^17;.16^0^16;.18^0^18;104^M^4;105^M^5;106^M^6;107^M^7;108^M^8;109^M^9;121^M1^1;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;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCA2 2083 printed Oct 16, 2024@18:09:12 Page 2
IBCA2 ;ALB/MRL - ADD NEW BILL ;01 JUN 88 12:00
+1 ;;2.0;INTEGRATED BILLING;**106,714**;21-MAR-94;Build 8
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;MAP TO DGCRA2
+5 ;
+6 WRITE !,"Passing bill to Accounts Receivable Module..."
DO SETUP^PRCASVC3
+7 IF $SELECT($PIECE(PRCASV("ARREC"),U)=-1:1,$PIECE(PRCASV("ARBIL"),U)=-1:1,1:0)
WRITE *7," ",$PIECE(PRCASV("ARREC"),"^",2),!,$$ETXT^IBEFUNC($PIECE(PRCASV("ARBIL"),"^",2))
DO Q
GOTO NREC^IBCA
+8 SET IBIDS(.01)=$PIECE(PRCASV("ARBIL"),"-",2)
SET IBIDS(.17)=$SELECT($DATA(IBIDS(.17)):IBIDS(.17),1:PRCASV("ARREC"))
+9 WRITE !,"Billing Record #",IBIDS(.01)," being established for '",VADM(1),"'..."
SET IBIDS(.02)=DFN
+10 ;D SC^IBCU3 ;calculate if SC veteran
+11 ; calculate if SC veteran
SET IBIDS(.18)=$$SC^IBCU3(DFN)
+12 ;calculate discharge bedsection
DO SPEC^IBCU4
+13 SET X=$PIECE($TEXT(WHERE),";;",2)
FOR I=0:0
SET I=$ORDER(IBIDS(I))
if 'I
QUIT
SET X1=$PIECE($EXTRACT(X,$FIND(X,I)+1,999),";",1)
SET $PIECE(IBDR($PIECE(X1,"^",1)),"^",$PIECE(X1,"^",2))=IBIDS(I)
+14 SET IBIFN=PRCASV("ARREC")
FOR I=0,"C","M","M1","S","U","U1"
IF $DATA(IBDR(I))
SET ^DGCR(399,IBIFN,I)=IBDR(I)
+15 SET $PIECE(^DGCR(399,0),"^",3)=IBIFN
SET $PIECE(^(0),"^",4)=$PIECE(^(0),"^",4)+1
WRITE !,"Cross-referencing new billing entry..."
SET DIK="^DGCR(399,"
SET DA=IBIFN
DO IX1^DIK
KILL DA,DIK
+16 SET IBYN=1
WRITE !!,*7,"Billing Record #",$PIECE(^DGCR(399,+IBIFN,0),"^",1)," established for '",VADM(1),"'..."
+17 KILL DGPTUPDT
DO ^IBCU6
Q KILL %,%DT,IBI,IBJ,IBDSDT,IBX,IB,IBA,IBNWBL,IBBT,IBIDS,I,J,VADM,X,X1,X2,X3,X4,Y,DGDIRA,DGDIRB,DGDIR0,DIR,DGRVRCAL
QUIT
+1 ;
XREF FOR IBI1=0:0
SET IBI1=$ORDER(^DD(399,IBI,1,IBI1))
if 'IBI1
QUIT
IF $DATA(^DD(399,IBI,1,IBI1,1))
SET DA=IBIFN
SET X=IBIDS(IBI)
XECUTE ^DD(399,IBI,1,IBI1,1)
+1 QUIT
+2 ; IB*2.0*714 added field .28 to WHERE tag.
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;.11^0^11;.17^0^17;.16^0^16;.18^0^18;.19^0^19;.22^0^22;.27^0^27;.28^0^28;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;
+1 ;
WHEREOLD ;.01^0^1;.02^0^2;.03^0^3;.04^0^4;.05^0^5;.06^0^6;.07^0^7;.08^0^8;.11^0^11;.17^0^17;.16^0^16;.18^0^18;104^M^4;105^M^5;106^M^6;107^M^7;108^M^8;109^M^9;121^M1^1;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;
+1 QUIT
