- 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
