IBCCC2 ;ALB/AAS - CANCEL AND CLONE A BILL - CONTINUED ;25-JAN-90
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;MAP TO DGCRCC2
;
;STEP 5 - get remainder of data to move and store in MCCR then x-ref
;STEP 6 - go to screens, come out to IBB1 or something like that
;
STEP5 S IBIFN1=$P(^DGCR(399,IBIFN,0),"^",15) G END:$S(IBIFN1="":1,'$D(^DGCR(399,IBIFN1,0)):1,1:0)
;
;move pure data nodes
F I="I1","I2","I3","M1" I $D(^DGCR(399,IBIFN1,I)) S ^DGCR(399,IBIFN,I)=^DGCR(399,IBIFN1,I)
;
;move top level data node.
F I="U","U1","U2","UF2","UF3","UF31","C","M" I $D(^DGCR(399,IBIFN1,I)) S IBND(I)=^(I) D @I
;
;move multiple level data
F I="CC","OC","OP","RC","CP","CV" I $D(^DGCR(399,IBIFN1,I,0)) D @I
;
D INDEX
;
D ^IBCCC3 ; copy table files (362.3)
;
D COPYB^IBCDC(IBIFN1,IBIFN) ; update auto biller files/fields
;
STEP6 S IBV=0,IBAC=1 D ^IBCSCU,^IBCSC1 G END:'$T D ^IBCB1
END K DFN,IB,IBA,IBA2,IBAD,IBADD1,IBBNO,IBCAN,IBCCC,IBDA,IBDPT,IBDR,IBDT,IBI,IBI1,IBIDS,IBIFN,IBIFN1,IBND,IBQUIT,IBU,IBUN,IBARST
K IBV,IBV1,IBW,IBWW,IBYN,IBZZ,PRCASV,PRCAERCD,PRCAERR,PRCASVC,PRCAT,IBBT,IBCH,IBNDS,IBOA,IBREV,IBX,DGXRF1,VAEL,VAERR,IBAC,IBCCC,IBIFN,IBDD1,IBIN,DGREV,DGREV00,DGREVHDR,IBCHK
K IBBS,IBLS,DGPCM,IBIP,IBND0,IBNDU,IBO,IBPTF,IBST,IBUC,IBDD,D,%,%DT,DIC,VA,VADM,X,X1,X2,X3,X4,Y,I,J,K,DGRVRCAL,DDH,DGACTDT,DGAMNT,DGBR,DGBRN,DGBSI,DGBSLOS,IBA1,IBOD,IBINS,IBN,IBPROC,DGFUNC,DGIFN
G ^IBCCC
;
;
U F J=3,4,7,10,11,13:1:17 I $P(IBND("U"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U"),"^",J)=$P(IBND("U"),"^",J)
Q
U1 F J=1:1:9,13,14 I $P(IBND("U1"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U1"),"^",J)=$P(IBND("U1"),"^",J)
Q
U2 F J=1,2,3 I $P(IBND("U2"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U2"),"^",J)=$P(IBND("U2"),"^",J)
Q
UF2 F J=1 I $P(IBND("UF2"),"^",J)]"" S $P(^DGCR(399,IBIFN,"UF2"),"^",J)=$P(IBND("UF2"),"^",J)
Q
UF3 F J=1:1:7 I $P(IBND("UF3"),"^",J)]"" S $P(^DGCR(399,IBIFN,"UF3"),"^",J)=$P(IBND("UF3"),"^",J)
Q
UF31 F J=1,2 I $P(IBND("UF31"),"^",J)]"" S $P(^DGCR(399,IBIFN,"UF31"),"^",J)=$P(IBND("UF31"),"^",J)
Q
C F J=10 I $P(IBND("C"),"^",J)]"" S $P(^DGCR(399,IBIFN,"C"),"^",J)=$P(IBND("C"),"^",J)
I '$D(^DGCR(399,IBIFN1,"CP")) D CP1
Q
M F J=1:1:14 I $P(IBND("M"),"^",J)]"" S $P(^DGCR(399,IBIFN,"M"),"^",J)=$P(IBND("M"),"^",J)
Q
CC S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
S IBDD=399.04 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
OP S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
S IBDD=399.043 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
Q
OC S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
S IBDD=399.041 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
Q
CV S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
S IBDD=399.047 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
Q
RC S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
S IBDD=399.042 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J I $D(^(J,0)) S IBND("RC")=^(0) F K=1:1:8 S $P(^DGCR(399,IBIFN,I,J,0),"^",K)=$P(IBND("RC"),"^",K),X=$P(IBND("RC"),"^",K)
Q
CP S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
S IBDD=399.0304 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J I $D(^(J,0)) S IBND("CP")=^(0) F K=1:1:7,9:1:14 S $P(^DGCR(399,IBIFN,I,J,0),"^",K)=$P(IBND("CP"),"^",K)
CP1 S IBCOD=$P($G(^DGCR(399,IBIFN,0)),"^",9) Q:IBCOD=""!('$D(^DGCR(399,IBIFN1,"C")))
S:'$D(^DGCR(399,IBIFN,"CP",0)) ^DGCR(399,IBIFN,"CP",0)="^399.0304AVI"
I IBCOD=9 F DGI=4,5,6 I $P(^DGCR(399,IBIFN1,"C"),"^",DGI) S X=$P(^("C"),"^",DGI)_";ICD0(",DGPROCDT=$P(^("C"),"^",DGI+7) D FILE
I IBCOD=4 F DGI=1,2,3 I $P(^DGCR(399,IBIFN1,"C"),"^",DGI) S X=$P(^("C"),"^",DGI)_";ICPT(",DGPROCDT=$P(^("C"),"^",DGI+10) D FILE
I IBCOD=5 F DGI=7,8,9 I $P(^DGCR(399,IBIFN1,"C"),"^",DGI) S X=$P(^("C"),"^",DGI)_";ICPT(",DGPROCDT=$P(^("C"),"^",DGI+4) D FILE
Q
;
FILE S DIC(0)="L",DLAYGO=399,DA(1)=IBIFN,DIC="^DGCR(399,"_DA(1)_",""CP""," K DD,DO Q:X="" D FILE^DICN Q:+Y<1 S DA=+Y
S DIE="^DGCR(399,"_DA(1)_",""CP"",",DR="1///"_DGPROCDT D ^DIE
K DIC,DIE,DR,DA,Y,DGPROCDT
Q
;
INDEX ;index entire file (set logic)
S DIK="^DGCR(399,",DA=IBIFN D IX1^DIK K DA,DIK
Q
IBCCC2 ;ALB/AAS - CANCEL AND CLONE A BILL - CONTINUED ;25-JAN-90
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;MAP TO DGCRCC2
+5 ;
+6 ;STEP 5 - get remainder of data to move and store in MCCR then x-ref
+7 ;STEP 6 - go to screens, come out to IBB1 or something like that
+8 ;
STEP5 SET IBIFN1=$PIECE(^DGCR(399,IBIFN,0),"^",15)
IF $SELECT(IBIFN1="":1,'$DATA(^DGCR(399,IBIFN1,0)):1,1:0)
GOTO END
+1 ;
+2 ;move pure data nodes
+3 FOR I="I1","I2","I3","M1"
IF $DATA(^DGCR(399,IBIFN1,I))
SET ^DGCR(399,IBIFN,I)=^DGCR(399,IBIFN1,I)
+4 ;
+5 ;move top level data node.
+6 FOR I="U","U1","U2","UF2","UF3","UF31","C","M"
IF $DATA(^DGCR(399,IBIFN1,I))
SET IBND(I)=^(I)
DO @I
+7 ;
+8 ;move multiple level data
+9 FOR I="CC","OC","OP","RC","CP","CV"
IF $DATA(^DGCR(399,IBIFN1,I,0))
DO @I
+10 ;
+11 DO INDEX
+12 ;
+13 ; copy table files (362.3)
DO ^IBCCC3
+14 ;
+15 ; update auto biller files/fields
DO COPYB^IBCDC(IBIFN1,IBIFN)
+16 ;
STEP6 SET IBV=0
SET IBAC=1
DO ^IBCSCU
DO ^IBCSC1
IF '$TEST
GOTO END
DO ^IBCB1
END KILL DFN,IB,IBA,IBA2,IBAD,IBADD1,IBBNO,IBCAN,IBCCC,IBDA,IBDPT,IBDR,IBDT,IBI,IBI1,IBIDS,IBIFN,IBIFN1,IBND,IBQUIT,IBU,IBUN,IBARST
+1 KILL IBV,IBV1,IBW,IBWW,IBYN,IBZZ,PRCASV,PRCAERCD,PRCAERR,PRCASVC,PRCAT,IBBT,IBCH,IBNDS,IBOA,IBREV,IBX,DGXRF1,VAEL,VAERR,IBAC,IBCCC,IBIFN,IBDD1,IBIN,DGREV,DGREV00,DGREVHDR,IBCHK
+2 KILL IBBS,IBLS,DGPCM,IBIP,IBND0,IBNDU,IBO,IBPTF,IBST,IBUC,IBDD,D,%,%DT,DIC,VA,VADM,X,X1,X2,X3,X4,Y,I,J,K,DGRVRCAL,DDH,DGACTDT,DGAMNT,DGBR,DGBRN,DGBSI,DGBSLOS,IBA1,IBOD,IBINS,IBN,IBPROC,DGFUNC,DGIFN
+3 GOTO ^IBCCC
+4 ;
+5 ;
U FOR J=3,4,7,10,11,13:1:17
IF $PIECE(IBND("U"),"^",J)]""
SET $PIECE(^DGCR(399,IBIFN,"U"),"^",J)=$PIECE(IBND("U"),"^",J)
+1 QUIT
U1 FOR J=1:1:9,13,14
IF $PIECE(IBND("U1"),"^",J)]""
SET $PIECE(^DGCR(399,IBIFN,"U1"),"^",J)=$PIECE(IBND("U1"),"^",J)
+1 QUIT
U2 FOR J=1,2,3
IF $PIECE(IBND("U2"),"^",J)]""
SET $PIECE(^DGCR(399,IBIFN,"U2"),"^",J)=$PIECE(IBND("U2"),"^",J)
+1 QUIT
UF2 FOR J=1
IF $PIECE(IBND("UF2"),"^",J)]""
SET $PIECE(^DGCR(399,IBIFN,"UF2"),"^",J)=$PIECE(IBND("UF2"),"^",J)
+1 QUIT
UF3 FOR J=1:1:7
IF $PIECE(IBND("UF3"),"^",J)]""
SET $PIECE(^DGCR(399,IBIFN,"UF3"),"^",J)=$PIECE(IBND("UF3"),"^",J)
+1 QUIT
UF31 FOR J=1,2
IF $PIECE(IBND("UF31"),"^",J)]""
SET $PIECE(^DGCR(399,IBIFN,"UF31"),"^",J)=$PIECE(IBND("UF31"),"^",J)
+1 QUIT
C FOR J=10
IF $PIECE(IBND("C"),"^",J)]""
SET $PIECE(^DGCR(399,IBIFN,"C"),"^",J)=$PIECE(IBND("C"),"^",J)
+1 IF '$DATA(^DGCR(399,IBIFN1,"CP"))
DO CP1
+2 QUIT
M FOR J=1:1:14
IF $PIECE(IBND("M"),"^",J)]""
SET $PIECE(^DGCR(399,IBIFN,"M"),"^",J)=$PIECE(IBND("M"),"^",J)
+1 QUIT
CC SET ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
+1 SET IBDD=399.04
FOR J=0:0
SET J=$ORDER(^DGCR(399,IBIFN1,I,J))
IF 'J
QUIT
IF $DATA(^(J,0))
SET ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0)
SET X=$PIECE(^(0),"^")
OP SET ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
+1 SET IBDD=399.043
FOR J=0:0
SET J=$ORDER(^DGCR(399,IBIFN1,I,J))
IF 'J
QUIT
IF $DATA(^(J,0))
SET ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0)
SET X=$PIECE(^(0),"^")
+2 QUIT
OC SET ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
+1 SET IBDD=399.041
FOR J=0:0
SET J=$ORDER(^DGCR(399,IBIFN1,I,J))
IF 'J
QUIT
IF $DATA(^(J,0))
SET ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0)
SET X=$PIECE(^(0),"^")
+2 QUIT
CV SET ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
+1 SET IBDD=399.047
FOR J=0:0
SET J=$ORDER(^DGCR(399,IBIFN1,I,J))
IF 'J
QUIT
IF $DATA(^(J,0))
SET ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0)
SET X=$PIECE(^(0),"^")
+2 QUIT
RC SET ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
+1 SET IBDD=399.042
FOR J=0:0
SET J=$ORDER(^DGCR(399,IBIFN1,I,J))
IF 'J
QUIT
IF $DATA(^(J,0))
SET IBND("RC")=^(0)
FOR K=1:1:8
SET $PIECE(^DGCR(399,IBIFN,I,J,0),"^",K)=$PIECE(IBND("RC"),"^",K)
SET X=$PIECE(IBND("RC"),"^",K)
+2 QUIT
CP SET ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
+1 SET IBDD=399.0304
FOR J=0:0
SET J=$ORDER(^DGCR(399,IBIFN1,I,J))
IF 'J
QUIT
IF $DATA(^(J,0))
SET IBND("CP")=^(0)
FOR K=1:1:7,9:1:14
SET $PIECE(^DGCR(399,IBIFN,I,J,0),"^",K)=$PIECE(IBND("CP"),"^",K)
CP1 SET IBCOD=$PIECE($GET(^DGCR(399,IBIFN,0)),"^",9)
IF IBCOD=""!('$DATA(^DGCR(399,IBIFN1,"C")))
QUIT
+1 IF '$DATA(^DGCR(399,IBIFN,"CP",0))
SET ^DGCR(399,IBIFN,"CP",0)="^399.0304AVI"
+2 IF IBCOD=9
FOR DGI=4,5,6
IF $PIECE(^DGCR(399,IBIFN1,"C"),"^",DGI)
SET X=$PIECE(^("C"),"^",DGI)_";ICD0("
SET DGPROCDT=$PIECE(^("C"),"^",DGI+7)
DO FILE
+3 IF IBCOD=4
FOR DGI=1,2,3
IF $PIECE(^DGCR(399,IBIFN1,"C"),"^",DGI)
SET X=$PIECE(^("C"),"^",DGI)_";ICPT("
SET DGPROCDT=$PIECE(^("C"),"^",DGI+10)
DO FILE
+4 IF IBCOD=5
FOR DGI=7,8,9
IF $PIECE(^DGCR(399,IBIFN1,"C"),"^",DGI)
SET X=$PIECE(^("C"),"^",DGI)_";ICPT("
SET DGPROCDT=$PIECE(^("C"),"^",DGI+4)
DO FILE
+5 QUIT
+6 ;
FILE SET DIC(0)="L"
SET DLAYGO=399
SET DA(1)=IBIFN
SET DIC="^DGCR(399,"_DA(1)_",""CP"","
KILL DD,DO
IF X=""
QUIT
DO FILE^DICN
IF +Y<1
QUIT
SET DA=+Y
+1 SET DIE="^DGCR(399,"_DA(1)_",""CP"","
SET DR="1///"_DGPROCDT
DO ^DIE
+2 KILL DIC,DIE,DR,DA,Y,DGPROCDT
+3 QUIT
+4 ;
INDEX ;index entire file (set logic)
+1 SET DIK="^DGCR(399,"
SET DA=IBIFN
DO IX1^DIK
KILL DA,DIK
+2 QUIT
