- RCDPEMA ;ALB/PJH - AUTO-POSTING RECEIPT CREATION ;Oct 15, 2014@12:37:52
- ;;4.5;Accounts Receivable;**298,304,318,321,326**;Mar 20, 1995;Build 26
- ;Per VA Directive 6402, this routine should not be modified.
- ;
- RCPTDET(RCRZ,RECTDA1,RCLINES,RCER) ; Adds detail to a receipt based on file 344.49 and exceptions in array RCLINES
- ; RCRZ = ien of ERA entry in file 344.49
- ; RECTDA1 = ien of receipt entry in file 344
- ; RCER = error array returned if passed by reference
- ; RCLINES = array to indicate which scratchpad lines can be posted (assigned a receipt)
- ;
- N DA,DIE,DR,Q,RCDUZ,RCLINE,RCOSEQ,RCQ,RCR,RCSPL,RCTRANDA,RCZ0,SEQLINES,RCSEQ,X,Y,Z,Z0,Z1
- ;
- S RCR=0 F S RCR=$O(^RCY(344.49,RCRZ,1,RCR)) Q:'RCR D
- . S RCZ0=$G(^RCY(344.49,RCRZ,1,RCR,0)),RCSEQ=$P(RCZ0,U)
- . ;Check first line for prefix to see if ERA line is valid for auto-post
- . I RCSEQ?1N.N,$P(RCZ0,U,9),$P($G(RCLINES($P(RCZ0,U,9))),U) S SEQLINES(RCSEQ)=""
- . ;Skip WORKLIST lines that do not need associated receipt detail
- . Q:'$D(SEQLINES(RCSEQ\1))
- . I RCSEQ'["." S RCSPL(+RCZ0)=$P(RCZ0,U,9) Q
- . I $S(+$P(RCZ0,U,3)=0:$P($G(^RCY(344.49,RCRZ,0)),U,3),1:$P(RCZ0,U,3)<0) S RCSPL(RCZ0\1,+RCZ0)=RCZ0 Q
- . S RCOSEQ=$G(RCSPL(RCSEQ\1)) ; PRCA*4.5*326
- . S RCDUZ=$$GET1^DIQ(344.41,RCOSEQ_","_RCRZ_",",6.01,"I") ; PRCA*4.5*326
- . S RCTRANDA=$$ADDTRAN^RCDPURET(RECTDA1,RCDUZ) ; PRCA*4.5*326 Pass RCDUZ
- . ;
- . I RCTRANDA'>0 D Q ; Error adding receipt detail - PRCA*4.5*318
- .. S RCER(1)=$$SETERR^RCDPEM0(1) ; PRCA*4.5*318 - pass RCPROC value to $$SETERR
- .. S RCER($O(RCER(""),-1)+1)=" NO DETAIL LINE ADDED TO RECEIPT "_$P($G(^RCY(344,RECTDA1,0)),U)_" FOR LINE #"_$P(RCZ0,U)_" IN EEOB WORKLIST SCRATCH PAD"
- . ;
- . ;Store receipt line detail
- . D DET(RCRZ,RCR,RECTDA1,RCTRANDA)
- . S RCSPL(RCZ0\1,+RCZ0)=RCZ0
- ;
- ; Update A/R CORRECTED PAYMENT multiple with apportionment for split lines
- S Z=0 F S Z=$O(RCSPL(Z)) Q:'Z S RCQ=+$G(RCSPL(Z)) I RCQ D
- .; Move EEOB if one claim entered-changed 10/19/11-see +25^RCDPEWL8
- . S Z1=$O(RCSPL(Z,"")) Q:Z1=""
- . I $O(RCSPL(Z,""),-1)=Z1,'$$SPLIT(Z,Z1,RCERA) Q ; No split occurred
- . S Z1=0 F S Z1=$O(RCSPL(Z,Z1)) Q:'Z1 S Z0=$G(RCSPL(Z,Z1)) D
- .. S Q=+$P($G(^RCY(344.4,RCRZ,1,RCQ,0)),U,2) ; EOB detail rec
- .. Q:'Q
- .. I '$P(Z0,U,7)!($P(Z0,U,2)="") D ; Suspense
- ... D SPL1^IBCEOBAR(Q,$S($P(Z0,U,2)="":"NO BILL",1:$P(Z0,U,2)),"",$P(Z0,U,6)) ; IA 4050
- .. E D
- ... D SPL1^IBCEOBAR(Q,$P(Z0,U,2),$P(Z0,U,7),$P(Z0,U,6)) ; Add the split bill # ; IA 4050
- . ; BEGIN - PRCA*4.5*321
- . ;Move/Copy/Remove EEOB detail for split line
- . N CLAIM,IEN3611,RCSPLIT,RCSUB,RCZSAV
- . ; Sub-array of split claim detail for individual line
- . M RCSPLIT=RCSPL(Z)
- . ; Protect Z subscript variable from overwrite by triggers
- . S RCZSAV=Z
- . ; Get scratchpad line number for this ERA line
- . S RCSUB=$O(^RCY(344.49,RCRZ,1,"ASEQ",Z,""))
- . ; Original claim number from Scratchpad line
- . S CLAIM=$$GET1^DIQ(344.491,RCSUB_","_RCRZ_",",.02)
- . ; EOB for original claim from ERA line
- . S IEN3611=$$GET1^DIQ(344.41,RCQ_","_RCRZ_",",.02,"I")
- . ; Automatic Move/Copy/Remove EOB
- . I $$AUTO^RCDPEM5(CLAIM,.RCSPLIT,RCERA,"A",IEN3611)
- . ; Restore Z
- . S Z=RCZSAV
- . ; END - PRCA*4.5*321 ;
- Q
- ;
- SPLIT(Z,Z1,RCERA) ;Check if worklist was split to single claim
- N SUB,NBILL,OBILL
- ;Find split line in scratchpad
- S SUB=$O(^RCY(344.49,RCERA,1,"B",Z1,"")) Q:'SUB 0
- ;Get original claim number from scratchpad
- S OBILL=$P($G(^RCY(344.49,RCERA,1,SUB-1,0)),U,2)
- ;New claim number
- S NBILL=$P(RCSPL(Z,Z1),U,2)
- ;If new and old claim are not the same this is a move via split
- I OBILL'="",OBILL'=NBILL Q 1
- ;Otherwise this is not a split
- Q 0
- ;
- DET(RCZ,RCR,RECTDA1,RCTRANDA) ; Store receipt detail
- ; RCZ = ien of entry file 344.49
- ; RCR = ien of entry in file 344.491
- ; RECTDA1 = ien of entry in file 344
- ; RCTRANDA = ien of entry in subfile 344.01
- ;
- N DIE,DA,DR,X,Y,Z,RCUP,RCCOM,RCZ0,RC0
- S RC0=$G(^RCY(344.49,RCZ,0))
- S RCZ0=$G(^RCY(344.49,RCZ,1,RCR,0))
- S DR="",RCUP=+$O(^RCY(344.49,RCZ,1,"B",+RCZ0/1,0)),RCUP=$G(^RCY(344.49,RCZ,1,RCUP,0))
- I $P(RCZ0,U,7) S DR=".09////^S X="_+$P(RCZ0,U,7)_"_$C(59)_""PRCA(430,"";"
- S DR=DR_".04////"_(+$P(RCZ0,U,3))_";.27////"_RCR_";"
- I $P(RC0,U,5)'="" S DR=DR_".1////"_$P(RC0,U,5)_";"
- I $P(RC0,U,6)'="" S DR=DR_".08////"_$P(RC0,U,6)_";"
- S Z=0 F S Z=$O(^RCY(344.49,RCZ,1,RCR,1,Z)) Q:'Z I $P($G(^(Z,0)),U,5)=1 S DR=DR_".28////1;" Q ; Update receipt line with dec adj flag
- S RCCOM=$P(RCZ0,U,10)
- I $P(RCUP,U,2)["**ADJ" S RCCOM=RCCOM_$S(RCCOM'="":"/",1:"")_$S($P($P(RCUP,U,2),"ADJ",2):"ERA adjustment - no bill referenced",1:"Total of EFT mismatched to ERA")
- I RCCOM]"" S DR=DR_"1.02////"_$E(RCCOM,1,60)_";"
- I $P($G(^RCY(344.49,RCZ,0)),U,4)'="" S DR=DR_".07////"_$P($G(^RCY(344.49,RCZ,0)),U,4)_";"
- S DA(1)=RECTDA1,DA=RCTRANDA,DIE="^RCY(344,"_DA(1)_",1,"
- D ^DIE
- ;Update comment history - PRCA*4.5*321
- D:RCCOM]"" AUDIT^RCDPECH(RECTDA1,RCTRANDA,RCZ,RCR)
- Q
- ; PRCA*4.5*326 Add RCDUZ parameter
- BLDRCPT(RCERA,RCDUZ) ; Create a receipt for Auto Posting ERA with multiple Receipts - alpha char at the 10th character
- ; LAYGO new entry to AR BATCH PAYMENT file (#344)
- ; input - RCERA = Pointer to 344.4
- ; returns new IEN on success, else zero
- ; called by auto-post process (RCDPEAP)
- ;
- N RECEIPT,TYPE,LASTREC
- S TYPE=$E($G(^RC(341.1,+$O(^RC(341.1,"AC",14,0)),0))) ; ^RC(341.1,0) = AR EVENT TYPE
- ; retrieve the last receipt recorded on the ERA (if it exists)
- S LASTREC=$$GETREC(RCERA)
- ; Make sure last receipt for the ERA is 10-chars long and the last char is between A - Y (can't be Z),
- ; Otherwise grab a new number and append "A"
- I LASTREC'="",$L(LASTREC)=10,$A($E(LASTREC,10))>64,$A($E(LASTREC,10))<90 D
- . S RECEIPT=$E(LASTREC,1,9)_$C($A($E(LASTREC,10))+1)
- E D
- . S RECEIPT=$$NEXT^RCDPUREC(TYPE_$E(DT,2,7))_"A"
- ;
- ; Prevents duplicate Receipt # entries from being filed
- F Q:'$D(^RCY(344,"B",RECEIPT)) D
- . S RECEIPT=$E(RECEIPT,1)_$E(1000001+$E(RECEIPT,2,7),2,7)_$E(RECEIPT,8,9)_"A"
- ;
- L +^RCY(344,"B",RECEIPT):DILOCKTM E Q 0 ; if LOCK timeout return zero
- ;
- ; add entry to AR BATCH PAYMENT file (#344)
- N %,%DT,D0,DA,DD,DI,DIC,DIE,DLAYGO,DO,DQ,DR,X,Y
- S DIC="^RCY(344,",DIC(0)="L",DLAYGO=344
- ; .02 = opened by .03 = date opened = transmission date
- ; .04 = type of payment
- ; .14 = status (set to 1:open)
- S DIC("DR")=".02////"_$S($G(RCDUZ):RCDUZ,1:DUZ)_";.03///"_DT_";.04////14;.14////1;"
- S X=RECEIPT
- D FILE^DICN
- L -^RCY(344,"B",RECEIPT)
- I Y>0 Q +Y ; Y set by DICN, return new IEN
- Q 0 ; entry not created
- ;
- GETREC(RCERA) ; returns the receipt number
- ; input - RCERA = ien of entry in 344.4
- ; output - returns the receipt number in external form
- N X,RECEIPT
- S RECEIPT=""
- S X=$O(^RCY(344.4,RCERA,1,"RECEIPT",""),-1) ; get last RECEIPT ien from 344.41 subfile
- S:X RECEIPT=$P($G(^RCY(344,X,0)),U) ; get external form of receipt
- Q RECEIPT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPEMA 6969 printed Feb 18, 2025@23:11:18 Page 2
- RCDPEMA ;ALB/PJH - AUTO-POSTING RECEIPT CREATION ;Oct 15, 2014@12:37:52
- +1 ;;4.5;Accounts Receivable;**298,304,318,321,326**;Mar 20, 1995;Build 26
- +2 ;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- RCPTDET(RCRZ,RECTDA1,RCLINES,RCER) ; Adds detail to a receipt based on file 344.49 and exceptions in array RCLINES
- +1 ; RCRZ = ien of ERA entry in file 344.49
- +2 ; RECTDA1 = ien of receipt entry in file 344
- +3 ; RCER = error array returned if passed by reference
- +4 ; RCLINES = array to indicate which scratchpad lines can be posted (assigned a receipt)
- +5 ;
- +6 NEW DA,DIE,DR,Q,RCDUZ,RCLINE,RCOSEQ,RCQ,RCR,RCSPL,RCTRANDA,RCZ0,SEQLINES,RCSEQ,X,Y,Z,Z0,Z1
- +7 ;
- +8 SET RCR=0
- FOR
- SET RCR=$ORDER(^RCY(344.49,RCRZ,1,RCR))
- if 'RCR
- QUIT
- Begin DoDot:1
- +9 SET RCZ0=$GET(^RCY(344.49,RCRZ,1,RCR,0))
- SET RCSEQ=$PIECE(RCZ0,U)
- +10 ;Check first line for prefix to see if ERA line is valid for auto-post
- +11 IF RCSEQ?1N.N
- IF $PIECE(RCZ0,U,9)
- IF $PIECE($GET(RCLINES($PIECE(RCZ0,U,9))),U)
- SET SEQLINES(RCSEQ)=""
- +12 ;Skip WORKLIST lines that do not need associated receipt detail
- +13 if '$DATA(SEQLINES(RCSEQ\1))
- QUIT
- +14 IF RCSEQ'["."
- SET RCSPL(+RCZ0)=$PIECE(RCZ0,U,9)
- QUIT
- +15 IF $SELECT(+$PIECE(RCZ0,U,3)=0:$PIECE($GET(^RCY(344.49,RCRZ,0)),U,3),1:$PIECE(RCZ0,U,3)<0)
- SET RCSPL(RCZ0\1,+RCZ0)=RCZ0
- QUIT
- +16 ; PRCA*4.5*326
- SET RCOSEQ=$GET(RCSPL(RCSEQ\1))
- +17 ; PRCA*4.5*326
- SET RCDUZ=$$GET1^DIQ(344.41,RCOSEQ_","_RCRZ_",",6.01,"I")
- +18 ; PRCA*4.5*326 Pass RCDUZ
- SET RCTRANDA=$$ADDTRAN^RCDPURET(RECTDA1,RCDUZ)
- +19 ;
- +20 ; Error adding receipt detail - PRCA*4.5*318
- IF RCTRANDA'>0
- Begin DoDot:2
- +21 ; PRCA*4.5*318 - pass RCPROC value to $$SETERR
- SET RCER(1)=$$SETERR^RCDPEM0(1)
- +22 SET RCER($ORDER(RCER(""),-1)+1)=" NO DETAIL LINE ADDED TO RECEIPT "_$PIECE($GET(^RCY(344,RECTDA1,0)),U)_" FOR LINE #"_$PIECE(RCZ0,U)_" IN EEOB WORKLIST SCRATCH PAD"
- End DoDot:2
- QUIT
- +23 ;
- +24 ;Store receipt line detail
- +25 DO DET(RCRZ,RCR,RECTDA1,RCTRANDA)
- +26 SET RCSPL(RCZ0\1,+RCZ0)=RCZ0
- End DoDot:1
- +27 ;
- +28 ; Update A/R CORRECTED PAYMENT multiple with apportionment for split lines
- +29 SET Z=0
- FOR
- SET Z=$ORDER(RCSPL(Z))
- if 'Z
- QUIT
- SET RCQ=+$GET(RCSPL(Z))
- IF RCQ
- Begin DoDot:1
- +30 ; Move EEOB if one claim entered-changed 10/19/11-see +25^RCDPEWL8
- +31 SET Z1=$ORDER(RCSPL(Z,""))
- if Z1=""
- QUIT
- +32 ; No split occurred
- IF $ORDER(RCSPL(Z,""),-1)=Z1
- IF '$$SPLIT(Z,Z1,RCERA)
- QUIT
- +33 SET Z1=0
- FOR
- SET Z1=$ORDER(RCSPL(Z,Z1))
- if 'Z1
- QUIT
- SET Z0=$GET(RCSPL(Z,Z1))
- Begin DoDot:2
- +34 ; EOB detail rec
- SET Q=+$PIECE($GET(^RCY(344.4,RCRZ,1,RCQ,0)),U,2)
- +35 if 'Q
- QUIT
- +36 ; Suspense
- IF '$PIECE(Z0,U,7)!($PIECE(Z0,U,2)="")
- Begin DoDot:3
- +37 ; IA 4050
- DO SPL1^IBCEOBAR(Q,$SELECT($PIECE(Z0,U,2)="":"NO BILL",1:$PIECE(Z0,U,2)),"",$PIECE(Z0,U,6))
- End DoDot:3
- +38 IF '$TEST
- Begin DoDot:3
- +39 ; Add the split bill # ; IA 4050
- DO SPL1^IBCEOBAR(Q,$PIECE(Z0,U,2),$PIECE(Z0,U,7),$PIECE(Z0,U,6))
- End DoDot:3
- End DoDot:2
- +40 ; BEGIN - PRCA*4.5*321
- +41 ;Move/Copy/Remove EEOB detail for split line
- +42 NEW CLAIM,IEN3611,RCSPLIT,RCSUB,RCZSAV
- +43 ; Sub-array of split claim detail for individual line
- +44 MERGE RCSPLIT=RCSPL(Z)
- +45 ; Protect Z subscript variable from overwrite by triggers
- +46 SET RCZSAV=Z
- +47 ; Get scratchpad line number for this ERA line
- +48 SET RCSUB=$ORDER(^RCY(344.49,RCRZ,1,"ASEQ",Z,""))
- +49 ; Original claim number from Scratchpad line
- +50 SET CLAIM=$$GET1^DIQ(344.491,RCSUB_","_RCRZ_",",.02)
- +51 ; EOB for original claim from ERA line
- +52 SET IEN3611=$$GET1^DIQ(344.41,RCQ_","_RCRZ_",",.02,"I")
- +53 ; Automatic Move/Copy/Remove EOB
- +54 IF $$AUTO^RCDPEM5(CLAIM,.RCSPLIT,RCERA,"A",IEN3611)
- +55 ; Restore Z
- +56 SET Z=RCZSAV
- +57 ; END - PRCA*4.5*321 ;
- End DoDot:1
- +58 QUIT
- +59 ;
- SPLIT(Z,Z1,RCERA) ;Check if worklist was split to single claim
- +1 NEW SUB,NBILL,OBILL
- +2 ;Find split line in scratchpad
- +3 SET SUB=$ORDER(^RCY(344.49,RCERA,1,"B",Z1,""))
- if 'SUB
- QUIT 0
- +4 ;Get original claim number from scratchpad
- +5 SET OBILL=$PIECE($GET(^RCY(344.49,RCERA,1,SUB-1,0)),U,2)
- +6 ;New claim number
- +7 SET NBILL=$PIECE(RCSPL(Z,Z1),U,2)
- +8 ;If new and old claim are not the same this is a move via split
- +9 IF OBILL'=""
- IF OBILL'=NBILL
- QUIT 1
- +10 ;Otherwise this is not a split
- +11 QUIT 0
- +12 ;
- DET(RCZ,RCR,RECTDA1,RCTRANDA) ; Store receipt detail
- +1 ; RCZ = ien of entry file 344.49
- +2 ; RCR = ien of entry in file 344.491
- +3 ; RECTDA1 = ien of entry in file 344
- +4 ; RCTRANDA = ien of entry in subfile 344.01
- +5 ;
- +6 NEW DIE,DA,DR,X,Y,Z,RCUP,RCCOM,RCZ0,RC0
- +7 SET RC0=$GET(^RCY(344.49,RCZ,0))
- +8 SET RCZ0=$GET(^RCY(344.49,RCZ,1,RCR,0))
- +9 SET DR=""
- SET RCUP=+$ORDER(^RCY(344.49,RCZ,1,"B",+RCZ0/1,0))
- SET RCUP=$GET(^RCY(344.49,RCZ,1,RCUP,0))
- +10 IF $PIECE(RCZ0,U,7)
- SET DR=".09////^S X="_+$PIECE(RCZ0,U,7)_"_$C(59)_""PRCA(430,"";"
- +11 SET DR=DR_".04////"_(+$PIECE(RCZ0,U,3))_";.27////"_RCR_";"
- +12 IF $PIECE(RC0,U,5)'=""
- SET DR=DR_".1////"_$PIECE(RC0,U,5)_";"
- +13 IF $PIECE(RC0,U,6)'=""
- SET DR=DR_".08////"_$PIECE(RC0,U,6)_";"
- +14 ; Update receipt line with dec adj flag
- SET Z=0
- FOR
- SET Z=$ORDER(^RCY(344.49,RCZ,1,RCR,1,Z))
- if 'Z
- QUIT
- IF $PIECE($GET(^(Z,0)),U,5)=1
- SET DR=DR_".28////1;"
- QUIT
- +15 SET RCCOM=$PIECE(RCZ0,U,10)
- +16 IF $PIECE(RCUP,U,2)["**ADJ"
- SET RCCOM=RCCOM_$SELECT(RCCOM'="":"/",1:"")_$SELECT($PIECE($PIECE(RCUP,U,2),"ADJ",2):"ERA adjustment - no bill referenced",1:"Total of EFT mismatched to ERA")
- +17 IF RCCOM]""
- SET DR=DR_"1.02////"_$EXTRACT(RCCOM,1,60)_";"
- +18 IF $PIECE($GET(^RCY(344.49,RCZ,0)),U,4)'=""
- SET DR=DR_".07////"_$PIECE($GET(^RCY(344.49,RCZ,0)),U,4)_";"
- +19 SET DA(1)=RECTDA1
- SET DA=RCTRANDA
- SET DIE="^RCY(344,"_DA(1)_",1,"
- +20 DO ^DIE
- +21 ;Update comment history - PRCA*4.5*321
- +22 if RCCOM]""
- DO AUDIT^RCDPECH(RECTDA1,RCTRANDA,RCZ,RCR)
- +23 QUIT
- +24 ; PRCA*4.5*326 Add RCDUZ parameter
- BLDRCPT(RCERA,RCDUZ) ; Create a receipt for Auto Posting ERA with multiple Receipts - alpha char at the 10th character
- +1 ; LAYGO new entry to AR BATCH PAYMENT file (#344)
- +2 ; input - RCERA = Pointer to 344.4
- +3 ; returns new IEN on success, else zero
- +4 ; called by auto-post process (RCDPEAP)
- +5 ;
- +6 NEW RECEIPT,TYPE,LASTREC
- +7 ; ^RC(341.1,0) = AR EVENT TYPE
- SET TYPE=$EXTRACT($GET(^RC(341.1,+$ORDER(^RC(341.1,"AC",14,0)),0)))
- +8 ; retrieve the last receipt recorded on the ERA (if it exists)
- +9 SET LASTREC=$$GETREC(RCERA)
- +10 ; Make sure last receipt for the ERA is 10-chars long and the last char is between A - Y (can't be Z),
- +11 ; Otherwise grab a new number and append "A"
- +12 IF LASTREC'=""
- IF $LENGTH(LASTREC)=10
- IF $ASCII($EXTRACT(LASTREC,10))>64
- IF $ASCII($EXTRACT(LASTREC,10))<90
- Begin DoDot:1
- +13 SET RECEIPT=$EXTRACT(LASTREC,1,9)_$CHAR($ASCII($EXTRACT(LASTREC,10))+1)
- End DoDot:1
- +14 IF '$TEST
- Begin DoDot:1
- +15 SET RECEIPT=$$NEXT^RCDPUREC(TYPE_$EXTRACT(DT,2,7))_"A"
- End DoDot:1
- +16 ;
- +17 ; Prevents duplicate Receipt # entries from being filed
- +18 FOR
- if '$DATA(^RCY(344,"B",RECEIPT))
- QUIT
- Begin DoDot:1
- +19 SET RECEIPT=$EXTRACT(RECEIPT,1)_$EXTRACT(1000001+$EXTRACT(RECEIPT,2,7),2,7)_$EXTRACT(RECEIPT,8,9)_"A"
- End DoDot:1
- +20 ;
- +21 ; if LOCK timeout return zero
- LOCK +^RCY(344,"B",RECEIPT):DILOCKTM
- IF '$TEST
- QUIT 0
- +22 ;
- +23 ; add entry to AR BATCH PAYMENT file (#344)
- +24 NEW %,%DT,D0,DA,DD,DI,DIC,DIE,DLAYGO,DO,DQ,DR,X,Y
- +25 SET DIC="^RCY(344,"
- SET DIC(0)="L"
- SET DLAYGO=344
- +26 ; .02 = opened by .03 = date opened = transmission date
- +27 ; .04 = type of payment
- +28 ; .14 = status (set to 1:open)
- +29 SET DIC("DR")=".02////"_$SELECT($GET(RCDUZ):RCDUZ,1:DUZ)_";.03///"_DT_";.04////14;.14////1;"
- +30 SET X=RECEIPT
- +31 DO FILE^DICN
- +32 LOCK -^RCY(344,"B",RECEIPT)
- +33 ; Y set by DICN, return new IEN
- IF Y>0
- QUIT +Y
- +34 ; entry not created
- QUIT 0
- +35 ;
- GETREC(RCERA) ; returns the receipt number
- +1 ; input - RCERA = ien of entry in 344.4
- +2 ; output - returns the receipt number in external form
- +3 NEW X,RECEIPT
- +4 SET RECEIPT=""
- +5 ; get last RECEIPT ien from 344.41 subfile
- SET X=$ORDER(^RCY(344.4,RCERA,1,"RECEIPT",""),-1)
- +6 ; get external form of receipt
- if X
- SET RECEIPT=$PIECE($GET(^RCY(344,X,0)),U)
- +7 QUIT RECEIPT