RCTCSJS ;ALBANY/LEG - CROSS-SERVICING REJECTS SERVER;02/19/14 3:21 PM
V ;;4.5;Accounts Receivable;**301,323,336,343**;Mar 20, 1995;Build 59
;;Per VA Directive 6402, this routine should not be modified.
;Program to process CS REJECT server messages from AITC
;
;PRCA*4.5*323 a. Convert reject rec totals to absolute value
; b. Allow C2 B rec type or '3E' reject clear CS flag
;
;PRCA*4.5*336 Ensure CS date is reset for rejected recalls on bills
;
;PRCA*4.5*343 Only set the CS date for rejected recall transaction
; if the bill status is active (16).
;
;===============================================================================
SERVER G SERVER^RCTCSJS0
;
SETREJS ;
S IDXS=".01;1;2;3;4;5;6;7;8;9;10;11;12;13;14"
S BILLIEN=""
F S BILLIEN=$O(^XTMP(NMSPC,$J,"BILL",BILLIEN)),SBILL="" Q:'$L(BILLIEN) D ;
. F S SBILL=$O(^XTMP(NMSPC,$J,"BILL",BILLIEN,SBILL)),HDATE="" Q:'$L(SBILL) D ;
.. F S HDATE=$O(^XTMP(NMSPC,$J,"BILL",BILLIEN,SBILL,HDATE)),CSRC="" Q:'$L(HDATE) D ;
... F S CSRC=$O(^XTMP(NMSPC,$J,"BILL",BILLIEN,SBILL,HDATE,CSRC)),RTYP="" Q:CSRC="" D ;
.... F S RTYP=$O(^XTMP(NMSPC,$J,"BILL",BILLIEN,SBILL,HDATE,CSRC,RTYP)),RACTN="" Q:RTYP="" D ;
..... F S RACTN=$O(^XTMP(NMSPC,$J,"BILL",BILLIEN,SBILL,HDATE,CSRC,RTYP,RACTN)) Q:RACTN="" D ;
...... S CERRS=$P(^XTMP(NMSPC,$J,"BILL",BILLIEN,SBILL,HDATE,CSRC,RTYP,RACTN),U)
...... S ^XTMP(NMSPC,$J,"ERRCDS",CERRS,BILLIEN)="" ; log by errs found
...... S REC=ZDATE_U_CSRC_U_$TR(CERRS,",","^")
...... S $P(REC,U,12)=RTYP,$P(REC,U,13)=RACTN,$P(REC,U,14)=BCIDA,$P(REC,U,15)=XMZ
...... S PATID=$P(^PRCA(430,BILLIEN,0),U,7),OTHERID=$P(^PRCA(430,BILLIEN,0),U,9)
...... I OTHERID D ;
....... S IDNUMGLB=$P(^RCD(340,OTHERID,0),U),IDGLOB=$P(IDNUMGLB,";",2),IDNUM=+IDNUMGLB
....... S IDREC0=@("^"_IDGLOB_IDNUM_",0)")
....... S NAM=$P(IDREC0,U),SSN=$P(IDREC0,U,9)
...... I PATID S NAM=$P(^DPT(PATID,0),U),SSN=$P(^DPT(PATID,0),U,9)
...... S STATCNT=STATCNT-1
...... D UPDREJ
Q ; SETREJS
;
UPDREJ ;
K DR,DA,DD,DO,Y
;
; checks for valid bill
S DIC="^PRCA(430,",DIC(0)="KMNZ",X=BILLIEN D ^DIC
S KBILL=$E(SBILL,5,11)
;
; Set ID for errors if ARTXNID not available
N ERRORID
S ERRORID=$S($G(ARTXNID(BILLIEN))="":U_U_RECN,1:ARTXNID(BILLIEN))
;
I Y=-1 D Q ;
. S ZMSG="Unknown Bill: "_BILLIEN_"/"_SBILL_"/"_RTYP
. D RECERR(.ERRCNT,"UNK-BILL:",ZMSG,$P(ERRORID,U,3),.RECERR) Q ; UPDREJ ;
; checks if REJECT record was previously logged
S COMMENT="XMB "_XMZ_" "_BCIDA
;I $D(^PRCA(430,BILLIEN,18,"B",ZDATE)) D Q:PREV ;UPDREJ
;. S IDX="",PREV=0
;. F S IDX=$O(^PRCA(430,BILLIEN,18,"B",ZDATE,IDX)) Q:'IDX D ;
;.. I $P(^PRCA(430,BILLIEN,18,IDX,0),U,1,14)=$P(REC,U,1,14) S PREV=1 Q
;. I PREV D ;
;. . S ZMSG="BILL Previously Logged IEN: "_BILLIEN_"/"_SBILL_"/"_RTYP
;. . D RECERR(.ERRCNT,"BILL PREV LOGGED",ZMSG,$P(ERRORID,U,3),.RECERR)
;
; gets next rejects subfile entry number
K DR,DA,DD,DO
S DA(1)=+Y
S DIC="^PRCA(430,"_DA(1)_",18,"
S DIC(0)="KMNZ"
S DIC("P")=$P(^DD(430,172,0),"^",2)
S (DA,X)=$O(@(DIC_"""A"")"),-1)
D ^DIC
;
; set Reject Fields
K DD,DO
S DA(1)=BILLIEN
; S DA=$S(Y=-1:1,1:DA+1)
S DA=$S($O(^PRCA(430,BILLIEN,18,"A"),-1):($O(^PRCA(430,BILLIEN,18,"A"),-1)+1),1:1)
S DIE=DIC K DIC
S DR=""
D RJCDCONV
F PC=1:1:15 S DTA=$P(REC,U,PC) I $L(DTA) S DR=DR_$P(IDXS,";",PC)_"////"_DTA_";"
S DIC("DR")=DR
I $L(DR) D ;
. D ^DIE
. ; Re-Index AB x_ref
. S DIK(1)=".01^AB^B"
. S DIK="^PRCA(430,"_BILLIEN_",18," D ENALL^DIK ;,DA(1)=HDATE
. S $P(^PRCA(430,BILLIEN,18,0),U,3)=$O(^PRCA(430,BILLIEN,18,"A"),-1)
. ;
. D STOPFILE ; resets STOP TCSP REFERRAL FLAG
. D LOGBULTN ; logs data into Bulletin
Q ;UPDREJ
;
STOPFILE ;set stop referral data in file 430
N B0,DEBTOR,BTRNNUM
S B0=$G(^PRCA(430,BILLIEN,0))
S $P(^PRCA(430,BILLIEN,15),U,7,10)="1^"_RUNDT_U_"R"_U_$G(COMMENT)
I RTYP=1 D Q
.I RACTN="A" K ^PRCA(430,BILLIEN,15),^(16),^PRCA(430,"TCSP",BILLIEN)
.I RACTN="U" S $P(^PRCA(430,BILLIEN,19),U,1)="1" Q
.I RACTN="L" D Q ;PRCA*4.5*336
.. K DR I $P(^PRCA(430,BILLIEN,0),U,8)=16 S DR="151////^S X=DT;" ;PRCA*4.5*343
.. S DA=BILLIEN,DIE="^PRCA(430,",DR=$G(DR)_"152///@;153///@;154///@;155///@" D ^DIE K DIE,DR,DA ;PRCA*4.5*336/343
I RTYP="2" S DEBTOR=$P(B0,U,9) D Q
.I RACTN="A" K ^RCD(340,DEBTOR,7),^RCD(340,"TCSP",DEBTOR) Q
.I RACTN="B",$G(CERRS)["3E" K ^PRCA(430,BILLIEN,15),^(16),^PRCA(430,"TCSP",BILLIEN)
.I RACTN="L" D Q ;PRCA*4.5*336
.. S DA=DEBTOR,DIE="^RCD(340,",DR="7.02///@;7.03///@;7.04///@" D ^DIE K DIE,DR,DA ;PRCA*4.5*336/343
.. K DR I $P(^PRCA(430,BILLIEN,0),U,8)=16 S DR="151////^S X=DT;" ;PRCA*4.5*343
.. S DA=BILLIEN,DIE="^PRCA(430,",DR=$G(DR)_"152///@;153///@;154///@;155///@" D ^DIE K DIE,DR,DA ;PRCA*4.5*336/343
.I RACTN="U" S $P(^PRCA(430,BILLIEN,19),U,2)="1" Q
I RTYP="2A" D Q
.I RACTN="A" Q
.I RACTN="U" S $P(^PRCA(430,BILLIEN,19),U,3)="1" Q
I RTYP="2C" D Q
. I RACTN="A" S $P(^PRCA(430,BILLIEN,19),U,4)="1" Q
I RTYP=3 Q
I RTYP="5B" D Q
.I RACTN="U" I $D(ARTXNID(BILLIEN)) S TRNNUM=+$P(ARTXNID(BILLIEN),U,1) I TRNNUM D
..;N INDX
..S INDX=0
..F S INDX=$O(^PRCA(430,BILLIEN,17,INDX)) Q:+INDX=0 I $P($G(^PRCA(430,BILLIEN,17,INDX,0)),U,1)=TRNNUM S $P(^PRCA(430,BILLIEN,17,INDX,0),U,2)=1 S DR="151///DT",DIE="^PRCA(430,",DA=BILLIEN D ^DIE Q
Q
;
RECERR(ERRCNT,ETYP,ERRDATA,RECN,RECERR) ; log TRANSMITTED FORMAT err
S (ERRCNT,^XTMP(NMSPC,$J,"ERR",0))=$G(^XTMP(NMSPC,$J,"ERR",0))+1
S ^XTMP(NMSPC,$J,"ERR",ERRCNT)=RECN_U_ERRDATA
S RECERR=1
Q ;
LOGBULTN ; logs the bulletin records
S ERRS=$S($E(CERRS,$L(CERRS))=",":$E(CERRS,1,$L(CERRS)-1),1:CERRS)
S BLTNCNT=$G(BLTNCNT)+1
S BLTNREC=$E(NAM_BLNKS,1,20)_" "_$E(SSN_BLNKS,1,10)_$E(SBILL_BLNKS,1,12)
S BLTNREC=BLTNREC_$E(RTYP_BLNKS,1,5)_$E(RACTN_BLNKS,1,5)_$E($P(CERRS,",",1,$L(CERRS,",")-1)_BLNKS,1,26)
;
S ^XTMP(NMSPC,$J,"BULTN",BLTNCNT)=BLTNREC
S ^XTMP(NMSPC,$J,"SRC",CSRC,NAM,SBILL,BLTNCNT)=""
Q
RJCDCONV ;Will modify code string to convert code data to linked file pointer
N COD,CVI
F CVI=3:1:13 S COD=$P(REC,U,CVI) D:COD'=""
. I CVI>2,CVI<12 S COD=$O(^RC(348.5,"B",COD,0)),$P(REC,U,CVI)=COD Q
. I CVI=12 S COD=$O(^RC(348.7,"B",COD,0)),$P(REC,U,CVI)=COD Q
. I CVI=13 S COD=$O(^RC(348.6,"B",COD,0)),$P(REC,U,CVI)=COD
. Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCTCSJS 6370 printed Apr 09, 2024@20:53:25 Page 2
RCTCSJS ;ALBANY/LEG - CROSS-SERVICING REJECTS SERVER;02/19/14 3:21 PM
V ;;4.5;Accounts Receivable;**301,323,336,343**;Mar 20, 1995;Build 59
+1 ;;Per VA Directive 6402, this routine should not be modified.
+2 ;Program to process CS REJECT server messages from AITC
+3 ;
+4 ;PRCA*4.5*323 a. Convert reject rec totals to absolute value
+5 ; b. Allow C2 B rec type or '3E' reject clear CS flag
+6 ;
+7 ;PRCA*4.5*336 Ensure CS date is reset for rejected recalls on bills
+8 ;
+9 ;PRCA*4.5*343 Only set the CS date for rejected recall transaction
+10 ; if the bill status is active (16).
+11 ;
+12 ;===============================================================================
SERVER GOTO SERVER^RCTCSJS0
+1 ;
SETREJS ;
+1 SET IDXS=".01;1;2;3;4;5;6;7;8;9;10;11;12;13;14"
+2 SET BILLIEN=""
+3 ;
FOR
SET BILLIEN=$ORDER(^XTMP(NMSPC,$JOB,"BILL",BILLIEN))
SET SBILL=""
if '$LENGTH(BILLIEN)
QUIT
Begin DoDot:1
+4 ;
FOR
SET SBILL=$ORDER(^XTMP(NMSPC,$JOB,"BILL",BILLIEN,SBILL))
SET HDATE=""
if '$LENGTH(SBILL)
QUIT
Begin DoDot:2
+5 ;
FOR
SET HDATE=$ORDER(^XTMP(NMSPC,$JOB,"BILL",BILLIEN,SBILL,HDATE))
SET CSRC=""
if '$LENGTH(HDATE)
QUIT
Begin DoDot:3
+6 ;
FOR
SET CSRC=$ORDER(^XTMP(NMSPC,$JOB,"BILL",BILLIEN,SBILL,HDATE,CSRC))
SET RTYP=""
if CSRC=""
QUIT
Begin DoDot:4
+7 ;
FOR
SET RTYP=$ORDER(^XTMP(NMSPC,$JOB,"BILL",BILLIEN,SBILL,HDATE,CSRC,RTYP))
SET RACTN=""
if RTYP=""
QUIT
Begin DoDot:5
+8 ;
FOR
SET RACTN=$ORDER(^XTMP(NMSPC,$JOB,"BILL",BILLIEN,SBILL,HDATE,CSRC,RTYP,RACTN))
if RACTN=""
QUIT
Begin DoDot:6
+9 SET CERRS=$PIECE(^XTMP(NMSPC,$JOB,"BILL",BILLIEN,SBILL,HDATE,CSRC,RTYP,RACTN),U)
+10 ; log by errs found
SET ^XTMP(NMSPC,$JOB,"ERRCDS",CERRS,BILLIEN)=""
+11 SET REC=ZDATE_U_CSRC_U_$TRANSLATE(CERRS,",","^")
+12 SET $PIECE(REC,U,12)=RTYP
SET $PIECE(REC,U,13)=RACTN
SET $PIECE(REC,U,14)=BCIDA
SET $PIECE(REC,U,15)=XMZ
+13 SET PATID=$PIECE(^PRCA(430,BILLIEN,0),U,7)
SET OTHERID=$PIECE(^PRCA(430,BILLIEN,0),U,9)
+14 ;
IF OTHERID
Begin DoDot:7
+15 SET IDNUMGLB=$PIECE(^RCD(340,OTHERID,0),U)
SET IDGLOB=$PIECE(IDNUMGLB,";",2)
SET IDNUM=+IDNUMGLB
+16 SET IDREC0=@("^"_IDGLOB_IDNUM_",0)")
+17 SET NAM=$PIECE(IDREC0,U)
SET SSN=$PIECE(IDREC0,U,9)
End DoDot:7
+18 IF PATID
SET NAM=$PIECE(^DPT(PATID,0),U)
SET SSN=$PIECE(^DPT(PATID,0),U,9)
+19 SET STATCNT=STATCNT-1
+20 DO UPDREJ
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+21 ; SETREJS
QUIT
+22 ;
UPDREJ ;
+1 KILL DR,DA,DD,DO,Y
+2 ;
+3 ; checks for valid bill
+4 SET DIC="^PRCA(430,"
SET DIC(0)="KMNZ"
SET X=BILLIEN
DO ^DIC
+5 SET KBILL=$EXTRACT(SBILL,5,11)
+6 ;
+7 ; Set ID for errors if ARTXNID not available
+8 NEW ERRORID
+9 SET ERRORID=$SELECT($GET(ARTXNID(BILLIEN))="":U_U_RECN,1:ARTXNID(BILLIEN))
+10 ;
+11 ;
IF Y=-1
Begin DoDot:1
+12 SET ZMSG="Unknown Bill: "_BILLIEN_"/"_SBILL_"/"_RTYP
+13 ; UPDREJ ;
DO RECERR(.ERRCNT,"UNK-BILL:",ZMSG,$PIECE(ERRORID,U,3),.RECERR)
QUIT
End DoDot:1
QUIT
+14 ; checks if REJECT record was previously logged
+15 SET COMMENT="XMB "_XMZ_" "_BCIDA
+16 ;I $D(^PRCA(430,BILLIEN,18,"B",ZDATE)) D Q:PREV ;UPDREJ
+17 ;. S IDX="",PREV=0
+18 ;. F S IDX=$O(^PRCA(430,BILLIEN,18,"B",ZDATE,IDX)) Q:'IDX D ;
+19 ;.. I $P(^PRCA(430,BILLIEN,18,IDX,0),U,1,14)=$P(REC,U,1,14) S PREV=1 Q
+20 ;. I PREV D ;
+21 ;. . S ZMSG="BILL Previously Logged IEN: "_BILLIEN_"/"_SBILL_"/"_RTYP
+22 ;. . D RECERR(.ERRCNT,"BILL PREV LOGGED",ZMSG,$P(ERRORID,U,3),.RECERR)
+23 ;
+24 ; gets next rejects subfile entry number
+25 KILL DR,DA,DD,DO
+26 SET DA(1)=+Y
+27 SET DIC="^PRCA(430,"_DA(1)_",18,"
+28 SET DIC(0)="KMNZ"
+29 SET DIC("P")=$PIECE(^DD(430,172,0),"^",2)
+30 SET (DA,X)=$ORDER(@(DIC_"""A"")"),-1)
+31 DO ^DIC
+32 ;
+33 ; set Reject Fields
+34 KILL DD,DO
+35 SET DA(1)=BILLIEN
+36 ; S DA=$S(Y=-1:1,1:DA+1)
+37 SET DA=$SELECT($ORDER(^PRCA(430,BILLIEN,18,"A"),-1):($ORDER(^PRCA(430,BILLIEN,18,"A"),-1)+1),1:1)
+38 SET DIE=DIC
KILL DIC
+39 SET DR=""
+40 DO RJCDCONV
+41 FOR PC=1:1:15
SET DTA=$PIECE(REC,U,PC)
IF $LENGTH(DTA)
SET DR=DR_$PIECE(IDXS,";",PC)_"////"_DTA_";"
+42 SET DIC("DR")=DR
+43 ;
IF $LENGTH(DR)
Begin DoDot:1
+44 DO ^DIE
+45 ; Re-Index AB x_ref
+46 SET DIK(1)=".01^AB^B"
+47 ;,DA(1)=HDATE
SET DIK="^PRCA(430,"_BILLIEN_",18,"
DO ENALL^DIK
+48 SET $PIECE(^PRCA(430,BILLIEN,18,0),U,3)=$ORDER(^PRCA(430,BILLIEN,18,"A"),-1)
+49 ;
+50 ; resets STOP TCSP REFERRAL FLAG
DO STOPFILE
+51 ; logs data into Bulletin
DO LOGBULTN
End DoDot:1
+52 ;UPDREJ
QUIT
+53 ;
STOPFILE ;set stop referral data in file 430
+1 NEW B0,DEBTOR,BTRNNUM
+2 SET B0=$GET(^PRCA(430,BILLIEN,0))
+3 SET $PIECE(^PRCA(430,BILLIEN,15),U,7,10)="1^"_RUNDT_U_"R"_U_$GET(COMMENT)
+4 IF RTYP=1
Begin DoDot:1
+5 IF RACTN="A"
KILL ^PRCA(430,BILLIEN,15),^(16),^PRCA(430,"TCSP",BILLIEN)
+6 IF RACTN="U"
SET $PIECE(^PRCA(430,BILLIEN,19),U,1)="1"
QUIT
+7 ;PRCA*4.5*336
IF RACTN="L"
Begin DoDot:2
+8 ;PRCA*4.5*343
KILL DR
IF $PIECE(^PRCA(430,BILLIEN,0),U,8)=16
SET DR="151////^S X=DT;"
+9 ;PRCA*4.5*336/343
SET DA=BILLIEN
SET DIE="^PRCA(430,"
SET DR=$GET(DR)_"152///@;153///@;154///@;155///@"
DO ^DIE
KILL DIE,DR,DA
End DoDot:2
QUIT
End DoDot:1
QUIT
+10 IF RTYP="2"
SET DEBTOR=$PIECE(B0,U,9)
Begin DoDot:1
+11 IF RACTN="A"
KILL ^RCD(340,DEBTOR,7),^RCD(340,"TCSP",DEBTOR)
QUIT
+12 IF RACTN="B"
IF $GET(CERRS)["3E"
KILL ^PRCA(430,BILLIEN,15),^(16),^PRCA(430,"TCSP",BILLIEN)
+13 ;PRCA*4.5*336
IF RACTN="L"
Begin DoDot:2
+14 ;PRCA*4.5*336/343
SET DA=DEBTOR
SET DIE="^RCD(340,"
SET DR="7.02///@;7.03///@;7.04///@"
DO ^DIE
KILL DIE,DR,DA
+15 ;PRCA*4.5*343
KILL DR
IF $PIECE(^PRCA(430,BILLIEN,0),U,8)=16
SET DR="151////^S X=DT;"
+16 ;PRCA*4.5*336/343
SET DA=BILLIEN
SET DIE="^PRCA(430,"
SET DR=$GET(DR)_"152///@;153///@;154///@;155///@"
DO ^DIE
KILL DIE,DR,DA
End DoDot:2
QUIT
+17 IF RACTN="U"
SET $PIECE(^PRCA(430,BILLIEN,19),U,2)="1"
QUIT
End DoDot:1
QUIT
+18 IF RTYP="2A"
Begin DoDot:1
+19 IF RACTN="A"
QUIT
+20 IF RACTN="U"
SET $PIECE(^PRCA(430,BILLIEN,19),U,3)="1"
QUIT
End DoDot:1
QUIT
+21 IF RTYP="2C"
Begin DoDot:1
+22 IF RACTN="A"
SET $PIECE(^PRCA(430,BILLIEN,19),U,4)="1"
QUIT
End DoDot:1
QUIT
+23 IF RTYP=3
QUIT
+24 IF RTYP="5B"
Begin DoDot:1
+25 IF RACTN="U"
IF $DATA(ARTXNID(BILLIEN))
SET TRNNUM=+$PIECE(ARTXNID(BILLIEN),U,1)
IF TRNNUM
Begin DoDot:2
+26 ;N INDX
+27 SET INDX=0
+28 FOR
SET INDX=$ORDER(^PRCA(430,BILLIEN,17,INDX))
if +INDX=0
QUIT
IF $PIECE($GET(^PRCA(430,BILLIEN,17,INDX,0)),U,1)=TRNNUM
SET $PIECE(^PRCA(430,BILLIEN,17,INDX,0),U,2)=1
SET DR="151///DT"
SET DIE="^PRCA(430,"
SET DA=BILLIEN
DO ^DIE
QUIT
End DoDot:2
End DoDot:1
QUIT
+29 QUIT
+30 ;
RECERR(ERRCNT,ETYP,ERRDATA,RECN,RECERR) ; log TRANSMITTED FORMAT err
+1 SET (ERRCNT,^XTMP(NMSPC,$JOB,"ERR",0))=$GET(^XTMP(NMSPC,$JOB,"ERR",0))+1
+2 SET ^XTMP(NMSPC,$JOB,"ERR",ERRCNT)=RECN_U_ERRDATA
+3 SET RECERR=1
+4 ;
QUIT
LOGBULTN ; logs the bulletin records
+1 SET ERRS=$SELECT($EXTRACT(CERRS,$LENGTH(CERRS))=",":$EXTRACT(CERRS,1,$LENGTH(CERRS)-1),1:CERRS)
+2 SET BLTNCNT=$GET(BLTNCNT)+1
+3 SET BLTNREC=$EXTRACT(NAM_BLNKS,1,20)_" "_$EXTRACT(SSN_BLNKS,1,10)_$EXTRACT(SBILL_BLNKS,1,12)
+4 SET BLTNREC=BLTNREC_$EXTRACT(RTYP_BLNKS,1,5)_$EXTRACT(RACTN_BLNKS,1,5)_$EXTRACT($PIECE(CERRS,",",1,$LENGTH(CERRS,",")-1)_BLNKS,1,26)
+5 ;
+6 SET ^XTMP(NMSPC,$JOB,"BULTN",BLTNCNT)=BLTNREC
+7 SET ^XTMP(NMSPC,$JOB,"SRC",CSRC,NAM,SBILL,BLTNCNT)=""
+8 QUIT
RJCDCONV ;Will modify code string to convert code data to linked file pointer
+1 NEW COD,CVI
+2 FOR CVI=3:1:13
SET COD=$PIECE(REC,U,CVI)
if COD'=""
Begin DoDot:1
+3 IF CVI>2
IF CVI<12
SET COD=$ORDER(^RC(348.5,"B",COD,0))
SET $PIECE(REC,U,CVI)=COD
QUIT
+4 IF CVI=12
SET COD=$ORDER(^RC(348.7,"B",COD,0))
SET $PIECE(REC,U,CVI)=COD
QUIT
+5 IF CVI=13
SET COD=$ORDER(^RC(348.6,"B",COD,0))
SET $PIECE(REC,U,CVI)=COD
+6 QUIT
End DoDot:1
