RCXFMSCR ;WISC/RFJ-fms cash receipt (cr) code sheet generator ;1 Oct 97
;;4.5;Accounts Receivable;**90,114,148,172,204,203,173,220,184,375**;Mar 20, 1995;Build 15
;;Per VHA Directive 6402, this routine should not be modified.
Q
;
BUILDCR(RCRECTDA,RCGECSDA,RCEFT) ; generate a cr/tr code sheet for a receipt
; rcgecsda is the ien for the gcs stack file 2100.1 for rebuilds
; rceft = 1 if processing CR for an EFT deposit (CR to rev src cd 8NZZ)
; = 2 if processing TR for the receipt detail relating to an EFT
; (TR from 528704/8NZZ to original fund/rsc)
;
N AMOUNT,BILLDA,COUNT,CR2,DETAIL,DEPOSIT,DESCRIP,DOCTOTAL,FISCALYR,FMSTYPE,FUND,GECSFMS,LINE,RCDEPTDA,REVSRCE,TOTAL,TRANDA,TRANNUMB,UNAPPLY,UNAPPNUM,VENDORID,DEBIT
;
; build the lines for all payments on receipt
S RCEFT=+$G(RCEFT)
K ^TMP($J,"RCFMSCR") ; used for 215 report, not used here
D FMSLINES^RCXFMSC1(RCRECTDA)
K ^TMP($J,"RCFMSCR")
;
; unapplied payments to accounts
S TRANDA=0 F S TRANDA=$O(^RCY(344,RCRECTDA,1,TRANDA)) Q:'TRANDA D
. ; dollars applied in AR
. I $P(^RCY(344,RCRECTDA,1,TRANDA,0),"^",5) Q
. ; no dollars on transaction
. S AMOUNT=$P(^RCY(344,RCRECTDA,1,TRANDA,0),"^",4) I 'AMOUNT Q
. ;
. ; PRCA*4.5*375 - If sending CR doc, check for debit; if debit, subtract amount instead of add
. I RCEFT=1 D Q
. . N DATE
. . S DATE=$S(DT<3030926:"",DT'<3030926&(DT<$$ADDPTEDT^PRCAACC()):".4",1:"04")
. . S:$P(^RCY(344,RCRECTDA,1,TRANDA,0),"^",29)="D" AMOUNT=-AMOUNT
. . S TOTAL("5287"_DATE,"8NZZ","MCCFVALUE")=$G(TOTAL("5287"_$S(DT<3030926:"",1:"04"),"8NZZ","MCCFVALUE"))+AMOUNT
. S UNAPPLY($$GETUNAPP(RCRECTDA,TRANDA,1))=AMOUNT
;
; no code sheets to send
I '$D(DETAIL),'$D(TOTAL),'$D(UNAPPLY) Q "-1^No code sheets to send for this receipt"
;
; get the next common number in the series = station "-" nextnumber
; use (field 200 in file 344) if document previously sent
S TRANNUMB=$P($P($G(^RCY(344,RCRECTDA,2)),"^"),"-",2)
I TRANNUMB="" S TRANNUMB=$$ENUM^RCMSNUM
I TRANNUMB<0 Q "0^Unable to lookup next transaction number"
; remove the dash (i,e, 460-K1A05HY)
S TRANNUMB=$TR(TRANNUMB,"-")
;
S FISCALYR=$$FY^RCFN01(DT)
;
S COUNT=0,DOCTOTAL=0
; build detail line
S FMSTYPE="" F S FMSTYPE=$O(DETAIL(FMSTYPE)) Q:FMSTYPE="" D
. S BILLDA=0 F S BILLDA=$O(DETAIL(FMSTYPE,BILLDA)) Q:'BILLDA D
. . S AMOUNT=DETAIL(FMSTYPE,BILLDA),DOCTOTAL=DOCTOTAL+AMOUNT
. . S COUNT=COUNT+1
. . S LINE(COUNT)="LIN^~CRA^"_$S($L(COUNT)=1:"00",$L(COUNT)=2:"0",1:"")_COUNT
. . S $P(LINE(COUNT),"^",20)=$J(AMOUNT,0,2)
. . S $P(LINE(COUNT),"^",21)="I"
. . S $P(LINE(COUNT),"^",23)=FMSTYPE
. . S $P(LINE(COUNT),"^",24)="BD"
. . S $P(LINE(COUNT),"^",25)=$TR($P(^PRCA(430,BILLDA,0),"^"),"-")
. . S $P(LINE(COUNT),"^",26)=$$LINE^RCXFMSC1(BILLDA)
. . S $P(LINE(COUNT),"^",27)="~"
;
; build summary line
S FUND="" F S FUND=$O(TOTAL(FUND)) Q:FUND="" D
. S REVSRCE="" F S REVSRCE=$O(TOTAL(FUND,REVSRCE)) Q:REVSRCE="" D
. . S VENDORID="" F S VENDORID=$O(TOTAL(FUND,REVSRCE,VENDORID)) Q:VENDORID="" D
. . . S AMOUNT=TOTAL(FUND,REVSRCE,VENDORID),DOCTOTAL=DOCTOTAL+AMOUNT
. . . S DEBIT="" ; PRCA*4.5*375 - If negative amount, set debit flag
. . . S:AMOUNT<0 DEBIT=1,AMOUNT=$FN(AMOUNT,"-") ; PRCA*4.5*375 - If negative amount, set debit flag
. . . S COUNT=COUNT+1
. . . S LINE(COUNT)="LIN^~CRA^"_$S($L(COUNT)=1:"00",$L(COUNT)=2:"0",1:"")_COUNT
. . . S $P(LINE(COUNT),"^",4)=$S(FUND=4032:"03",1:FISCALYR)
. . . S $P(LINE(COUNT),"^",4)=$S($E(FUND,1,4)=5287:"05",1:FISCALYR)
. . . S $P(LINE(COUNT),"^",6)=FUND
. . . S $P(LINE(COUNT),"^",7)=$E(TRANNUMB,1,3) ; station #
. . . S $P(LINE(COUNT),"^",10)=REVSRCE
. . . ;I FUND=4032 S $P(LINE(COUNT),"^",13)="24GX40100"
. . . S $P(LINE(COUNT),"^",18)=VENDORID
. . . S $P(LINE(COUNT),"^",20)=$J(AMOUNT,0,2)
. . . S $P(LINE(COUNT),"^",21)=$S(DEBIT:"D",1:"I") ; PRCA*4.5*375 - Send Debit Flag if to FMS
. . . S $P(LINE(COUNT),"^",23)=23
. . . S $P(LINE(COUNT),"^",24)="~"
;
; build unapplied payment lines
S UNAPPNUM="" F S UNAPPNUM=$O(UNAPPLY(UNAPPNUM)) Q:UNAPPNUM="" D
. S AMOUNT=UNAPPLY(UNAPPNUM),DOCTOTAL=DOCTOTAL+AMOUNT
. S COUNT=COUNT+1
. S LINE(COUNT)="LIN^~CRA^"_$S($L(COUNT)=1:"00",$L(COUNT)=2:"0",1:"")_COUNT
. S $P(LINE(COUNT),"^",4)=FISCALYR
. S $P(LINE(COUNT),"^",6)=3875
. S $P(LINE(COUNT),"^",7)=$E(TRANNUMB,1,3) ; station #
. S $P(LINE(COUNT),"^",20)=$J(AMOUNT,0,2)
. S $P(LINE(COUNT),"^",21)="I"
. S $P(LINE(COUNT),"^",23)=17
. S $P(LINE(COUNT),"^",24)="~CRB"
. S $P(LINE(COUNT),"^",32)=UNAPPNUM
. S $P(LINE(COUNT),"^",33)="~"
;
; get data from file 344.1, the ar deposit file
S RCDEPTDA=$P(^RCY(344,RCRECTDA,0),"^",6),DEPOSIT=$G(^RCY(344.1,RCDEPTDA,0))
;
; build cr2, $p(deposit,^,3)=deposit date
N FMSDT S FMSDT=$$FMSDATE^RCBEUTRA(DT)
S CR2="CR2^"_$E(FMSDT,2,3)_"^"_$E(FMSDT,4,5)_"^"_$E(FMSDT,6,7)_"^^^^^^E^^^"
S CR2=CR2_$P(DEPOSIT,"^")_"^^"_$FN(DOCTOTAL,"-",2)_"^^" ; PRCA*4.5*375 - Suppress minus sign so we don't send negative values to FMS
S CR2=CR2_$E($P(DEPOSIT,"^",3),2,3)_"^"_$E($P(DEPOSIT,"^",3),4,5)_"^"_$E($P(DEPOSIT,"^",3),6,7)_"^~"
;
; put together document in gcs
N %DT,D,D0,DA,DI,DIC,DIE,DIQ2,DQ,DR
S DESCRIP="Receipt: "_$P(^RCY(344,RCRECTDA,0),"^")
I 'RCGECSDA D CONTROL^GECSUFMS("A",$E(TRANNUMB,1,3),TRANNUMB,"CR",10,0,"",DESCRIP)
I RCGECSDA D REBUILD^GECSUFM1(RCGECSDA,"A",10,"N","Rebuild "_DESCRIP) S GECSFMS("DA")=RCGECSDA
;
; store document in gcs
D SETCS^GECSSTAA(GECSFMS("DA"),CR2)
F COUNT=1:1 Q:'$D(LINE(COUNT)) D SETCS^GECSSTAA(GECSFMS("DA"),LINE(COUNT))
D SETCODE^GECSSDCT(GECSFMS("DA"),"D RETN^RCFMFN02")
D SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
;
; add/update entry in file 347 for unprocessed document report
N %DT,%X,D,DA347,D0,DI,DQ,DIC,ERROR,FMSDOCNO,X
S FMSDOCNO="CR-"_$P(GECSFMS("CTL"),"^",9)
S DA347=$O(^RC(347,"C",FMSDOCNO,0))
; if not in the file, addit fmsdocid cr id
I 'DA347 D OPEN^RCFMDRV1(FMSDOCNO,3,"RC"_$P($G(^RCY(344,RCRECTDA,0)),"^"),.DA347,.ERROR)
I DA347 D SSTAT^RCFMFN02(FMSDOCNO,1)
;
; return 1 for success ^ fms document transaction number
Q "1^"_FMSDOCNO
;
;
GETUNAPP(RCRECTDA,RCTRANDA,RCSTORE) ; get unapplied deposit number for receipt
; if $g(rcstore) store it with transaction
N UNAPPNUM
; if number is already assigned, use it
I $P($G(^RCY(344,RCRECTDA,1,RCTRANDA,2)),"^",5)'="" Q $P(^(2),"^",5)
;
S UNAPPNUM=$P(^RCY(344,RCRECTDA,0),"^")
; if the receipt number is more than 9 characters, take the last 9
I $L(UNAPPNUM)>9 S UNAPPNUM=$E(UNAPPNUM,$L(UNAPPNUM)-8,$L(UNAPPNUM))
S UNAPPNUM=UNAPPNUM_$TR($J(RCTRANDA,4)," ",0)
;
; store unapplied number
I $G(RCSTORE) D SETUNAPP^RCDPURET(RCRECTDA,RCTRANDA,UNAPPNUM)
;
Q UNAPPNUM
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCXFMSCR 7046 printed Dec 13, 2024@01:49:15 Page 2
RCXFMSCR ;WISC/RFJ-fms cash receipt (cr) code sheet generator ;1 Oct 97
+1 ;;4.5;Accounts Receivable;**90,114,148,172,204,203,173,220,184,375**;Mar 20, 1995;Build 15
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
BUILDCR(RCRECTDA,RCGECSDA,RCEFT) ; generate a cr/tr code sheet for a receipt
+1 ; rcgecsda is the ien for the gcs stack file 2100.1 for rebuilds
+2 ; rceft = 1 if processing CR for an EFT deposit (CR to rev src cd 8NZZ)
+3 ; = 2 if processing TR for the receipt detail relating to an EFT
+4 ; (TR from 528704/8NZZ to original fund/rsc)
+5 ;
+6 NEW AMOUNT,BILLDA,COUNT,CR2,DETAIL,DEPOSIT,DESCRIP,DOCTOTAL,FISCALYR,FMSTYPE,FUND,GECSFMS,LINE,RCDEPTDA,REVSRCE,TOTAL,TRANDA,TRANNUMB,UNAPPLY,UNAPPNUM,VENDORID,DEBIT
+7 ;
+8 ; build the lines for all payments on receipt
+9 SET RCEFT=+$GET(RCEFT)
+10 ; used for 215 report, not used here
KILL ^TMP($JOB,"RCFMSCR")
+11 DO FMSLINES^RCXFMSC1(RCRECTDA)
+12 KILL ^TMP($JOB,"RCFMSCR")
+13 ;
+14 ; unapplied payments to accounts
+15 SET TRANDA=0
FOR
SET TRANDA=$ORDER(^RCY(344,RCRECTDA,1,TRANDA))
if 'TRANDA
QUIT
Begin DoDot:1
+16 ; dollars applied in AR
+17 IF $PIECE(^RCY(344,RCRECTDA,1,TRANDA,0),"^",5)
QUIT
+18 ; no dollars on transaction
+19 SET AMOUNT=$PIECE(^RCY(344,RCRECTDA,1,TRANDA,0),"^",4)
IF 'AMOUNT
QUIT
+20 ;
+21 ; PRCA*4.5*375 - If sending CR doc, check for debit; if debit, subtract amount instead of add
+22 IF RCEFT=1
Begin DoDot:2
+23 NEW DATE
+24 SET DATE=$SELECT(DT<3030926:"",DT'<3030926&(DT<$$ADDPTEDT^PRCAACC()):".4",1:"04")
+25 if $PIECE(^RCY(344,RCRECTDA,1,TRANDA,0),"^",29)="D"
SET AMOUNT=-AMOUNT
+26 SET TOTAL("5287"_DATE,"8NZZ","MCCFVALUE")=$GET(TOTAL("5287"_$SELECT(DT<3030926:"",1:"04"),"8NZZ","MCCFVALUE"))+AMOUNT
End DoDot:2
QUIT
+27 SET UNAPPLY($$GETUNAPP(RCRECTDA,TRANDA,1))=AMOUNT
End DoDot:1
+28 ;
+29 ; no code sheets to send
+30 IF '$DATA(DETAIL)
IF '$DATA(TOTAL)
IF '$DATA(UNAPPLY)
QUIT "-1^No code sheets to send for this receipt"
+31 ;
+32 ; get the next common number in the series = station "-" nextnumber
+33 ; use (field 200 in file 344) if document previously sent
+34 SET TRANNUMB=$PIECE($PIECE($GET(^RCY(344,RCRECTDA,2)),"^"),"-",2)
+35 IF TRANNUMB=""
SET TRANNUMB=$$ENUM^RCMSNUM
+36 IF TRANNUMB<0
QUIT "0^Unable to lookup next transaction number"
+37 ; remove the dash (i,e, 460-K1A05HY)
+38 SET TRANNUMB=$TRANSLATE(TRANNUMB,"-")
+39 ;
+40 SET FISCALYR=$$FY^RCFN01(DT)
+41 ;
+42 SET COUNT=0
SET DOCTOTAL=0
+43 ; build detail line
+44 SET FMSTYPE=""
FOR
SET FMSTYPE=$ORDER(DETAIL(FMSTYPE))
if FMSTYPE=""
QUIT
Begin DoDot:1
+45 SET BILLDA=0
FOR
SET BILLDA=$ORDER(DETAIL(FMSTYPE,BILLDA))
if 'BILLDA
QUIT
Begin DoDot:2
+46 SET AMOUNT=DETAIL(FMSTYPE,BILLDA)
SET DOCTOTAL=DOCTOTAL+AMOUNT
+47 SET COUNT=COUNT+1
+48 SET LINE(COUNT)="LIN^~CRA^"_$SELECT($LENGTH(COUNT)=1:"00",$LENGTH(COUNT)=2:"0",1:"")_COUNT
+49 SET $PIECE(LINE(COUNT),"^",20)=$JUSTIFY(AMOUNT,0,2)
+50 SET $PIECE(LINE(COUNT),"^",21)="I"
+51 SET $PIECE(LINE(COUNT),"^",23)=FMSTYPE
+52 SET $PIECE(LINE(COUNT),"^",24)="BD"
+53 SET $PIECE(LINE(COUNT),"^",25)=$TRANSLATE($PIECE(^PRCA(430,BILLDA,0),"^"),"-")
+54 SET $PIECE(LINE(COUNT),"^",26)=$$LINE^RCXFMSC1(BILLDA)
+55 SET $PIECE(LINE(COUNT),"^",27)="~"
End DoDot:2
End DoDot:1
+56 ;
+57 ; build summary line
+58 SET FUND=""
FOR
SET FUND=$ORDER(TOTAL(FUND))
if FUND=""
QUIT
Begin DoDot:1
+59 SET REVSRCE=""
FOR
SET REVSRCE=$ORDER(TOTAL(FUND,REVSRCE))
if REVSRCE=""
QUIT
Begin DoDot:2
+60 SET VENDORID=""
FOR
SET VENDORID=$ORDER(TOTAL(FUND,REVSRCE,VENDORID))
if VENDORID=""
QUIT
Begin DoDot:3
+61 SET AMOUNT=TOTAL(FUND,REVSRCE,VENDORID)
SET DOCTOTAL=DOCTOTAL+AMOUNT
+62 ; PRCA*4.5*375 - If negative amount, set debit flag
SET DEBIT=""
+63 ; PRCA*4.5*375 - If negative amount, set debit flag
if AMOUNT<0
SET DEBIT=1
SET AMOUNT=$FNUMBER(AMOUNT,"-")
+64 SET COUNT=COUNT+1
+65 SET LINE(COUNT)="LIN^~CRA^"_$SELECT($LENGTH(COUNT)=1:"00",$LENGTH(COUNT)=2:"0",1:"")_COUNT
+66 SET $PIECE(LINE(COUNT),"^",4)=$SELECT(FUND=4032:"03",1:FISCALYR)
+67 SET $PIECE(LINE(COUNT),"^",4)=$SELECT($EXTRACT(FUND,1,4)=5287:"05",1:FISCALYR)
+68 SET $PIECE(LINE(COUNT),"^",6)=FUND
+69 ; station #
SET $PIECE(LINE(COUNT),"^",7)=$EXTRACT(TRANNUMB,1,3)
+70 SET $PIECE(LINE(COUNT),"^",10)=REVSRCE
+71 ;I FUND=4032 S $P(LINE(COUNT),"^",13)="24GX40100"
+72 SET $PIECE(LINE(COUNT),"^",18)=VENDORID
+73 SET $PIECE(LINE(COUNT),"^",20)=$JUSTIFY(AMOUNT,0,2)
+74 ; PRCA*4.5*375 - Send Debit Flag if to FMS
SET $PIECE(LINE(COUNT),"^",21)=$SELECT(DEBIT:"D",1:"I")
+75 SET $PIECE(LINE(COUNT),"^",23)=23
+76 SET $PIECE(LINE(COUNT),"^",24)="~"
End DoDot:3
End DoDot:2
End DoDot:1
+77 ;
+78 ; build unapplied payment lines
+79 SET UNAPPNUM=""
FOR
SET UNAPPNUM=$ORDER(UNAPPLY(UNAPPNUM))
if UNAPPNUM=""
QUIT
Begin DoDot:1
+80 SET AMOUNT=UNAPPLY(UNAPPNUM)
SET DOCTOTAL=DOCTOTAL+AMOUNT
+81 SET COUNT=COUNT+1
+82 SET LINE(COUNT)="LIN^~CRA^"_$SELECT($LENGTH(COUNT)=1:"00",$LENGTH(COUNT)=2:"0",1:"")_COUNT
+83 SET $PIECE(LINE(COUNT),"^",4)=FISCALYR
+84 SET $PIECE(LINE(COUNT),"^",6)=3875
+85 ; station #
SET $PIECE(LINE(COUNT),"^",7)=$EXTRACT(TRANNUMB,1,3)
+86 SET $PIECE(LINE(COUNT),"^",20)=$JUSTIFY(AMOUNT,0,2)
+87 SET $PIECE(LINE(COUNT),"^",21)="I"
+88 SET $PIECE(LINE(COUNT),"^",23)=17
+89 SET $PIECE(LINE(COUNT),"^",24)="~CRB"
+90 SET $PIECE(LINE(COUNT),"^",32)=UNAPPNUM
+91 SET $PIECE(LINE(COUNT),"^",33)="~"
End DoDot:1
+92 ;
+93 ; get data from file 344.1, the ar deposit file
+94 SET RCDEPTDA=$PIECE(^RCY(344,RCRECTDA,0),"^",6)
SET DEPOSIT=$GET(^RCY(344.1,RCDEPTDA,0))
+95 ;
+96 ; build cr2, $p(deposit,^,3)=deposit date
+97 NEW FMSDT
SET FMSDT=$$FMSDATE^RCBEUTRA(DT)
+98 SET CR2="CR2^"_$EXTRACT(FMSDT,2,3)_"^"_$EXTRACT(FMSDT,4,5)_"^"_$EXTRACT(FMSDT,6,7)_"^^^^^^E^^^"
+99 ; PRCA*4.5*375 - Suppress minus sign so we don't send negative values to FMS
SET CR2=CR2_$PIECE(DEPOSIT,"^")_"^^"_$FNUMBER(DOCTOTAL,"-",2)_"^^"
+100 SET CR2=CR2_$EXTRACT($PIECE(DEPOSIT,"^",3),2,3)_"^"_$EXTRACT($PIECE(DEPOSIT,"^",3),4,5)_"^"_$EXTRACT($PIECE(DEPOSIT,"^",3),6,7)_"^~"
+101 ;
+102 ; put together document in gcs
+103 NEW %DT,D,D0,DA,DI,DIC,DIE,DIQ2,DQ,DR
+104 SET DESCRIP="Receipt: "_$PIECE(^RCY(344,RCRECTDA,0),"^")
+105 IF 'RCGECSDA
DO CONTROL^GECSUFMS("A",$EXTRACT(TRANNUMB,1,3),TRANNUMB,"CR",10,0,"",DESCRIP)
+106 IF RCGECSDA
DO REBUILD^GECSUFM1(RCGECSDA,"A",10,"N","Rebuild "_DESCRIP)
SET GECSFMS("DA")=RCGECSDA
+107 ;
+108 ; store document in gcs
+109 DO SETCS^GECSSTAA(GECSFMS("DA"),CR2)
+110 FOR COUNT=1:1
if '$DATA(LINE(COUNT))
QUIT
DO SETCS^GECSSTAA(GECSFMS("DA"),LINE(COUNT))
+111 DO SETCODE^GECSSDCT(GECSFMS("DA"),"D RETN^RCFMFN02")
+112 DO SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
+113 ;
+114 ; add/update entry in file 347 for unprocessed document report
+115 NEW %DT,%X,D,DA347,D0,DI,DQ,DIC,ERROR,FMSDOCNO,X
+116 SET FMSDOCNO="CR-"_$PIECE(GECSFMS("CTL"),"^",9)
+117 SET DA347=$ORDER(^RC(347,"C",FMSDOCNO,0))
+118 ; if not in the file, addit fmsdocid cr id
+119 IF 'DA347
DO OPEN^RCFMDRV1(FMSDOCNO,3,"RC"_$PIECE($GET(^RCY(344,RCRECTDA,0)),"^"),.DA347,.ERROR)
+120 IF DA347
DO SSTAT^RCFMFN02(FMSDOCNO,1)
+121 ;
+122 ; return 1 for success ^ fms document transaction number
+123 QUIT "1^"_FMSDOCNO
+124 ;
+125 ;
GETUNAPP(RCRECTDA,RCTRANDA,RCSTORE) ; get unapplied deposit number for receipt
+1 ; if $g(rcstore) store it with transaction
+2 NEW UNAPPNUM
+3 ; if number is already assigned, use it
+4 IF $PIECE($GET(^RCY(344,RCRECTDA,1,RCTRANDA,2)),"^",5)'=""
QUIT $PIECE(^(2),"^",5)
+5 ;
+6 SET UNAPPNUM=$PIECE(^RCY(344,RCRECTDA,0),"^")
+7 ; if the receipt number is more than 9 characters, take the last 9
+8 IF $LENGTH(UNAPPNUM)>9
SET UNAPPNUM=$EXTRACT(UNAPPNUM,$LENGTH(UNAPPNUM)-8,$LENGTH(UNAPPNUM))
+9 SET UNAPPNUM=UNAPPNUM_$TRANSLATE($JUSTIFY(RCTRANDA,4)," ",0)
+10 ;
+11 ; store unapplied number
+12 IF $GET(RCSTORE)
DO SETUNAPP^RCDPURET(RCRECTDA,RCTRANDA,UNAPPNUM)
+13 ;
+14 QUIT UNAPPNUM
