RCBEPAYF ;WISC/RFJ-first party payment processing(called by rcbepay) ;1 Jun 00
;;4.5;Accounts Receivable;**153,301,322,315**;Mar 20, 1995;Build 67
;;Per VA Directive 6402, this routine should not be modified.
Q
;
;PRCA*4.5*322 Awaken commented line to post payemnt to
; implied bill# for receipt payment
;
FIRSTPTY() ; apply payment to first party account
; called by rcbepay
N PAYMENT,RCBILBAL,RCBILLDA,RCDATE,RCDEBTDA,RCERROR,RCREPAMT,RCSTATUS,RCTRANDA,X,CSBILL,CSBILLDA,CSDEP,IDX,PREV
K ^TMP("RCBEPAY",$J)
; acc't lookup info BB prca*4.5*301
S CSBILLDA=+$E($P(RCDATA,"^",7),22,99),CSDEP=$P(RCDATA,"^",19),CSBILL=$E($P(RCDATA,"^",7),1,3)_"-"_$E($P(RCDATA,"^",7),4,10)
I 'CSDEP S CSDEP=169 ;Default for missing pay type
I $E($G(CSDEP),1,3)=170 S CSBILLDA=$O(^PRCA(430,"B",CSBILL,0))
I RCDATA["PRCA(430," S CSBILLDA=+$P(RCDATA,"^",3)
I CSDEP>167,CSDEP<171 S RCBETYPE=CSDEP
;end PRCA*4.5*301
;
; look up account in debtor file
S RCDEBTDA=$$DEBT^RCEVUTL(RCACCT)
I RCDEBTDA<0 Q "1^Could not add Patient ("_RCACCT_") to debtor file"
;
; lock the debtor account
L +^RCD(340,RCDEBTDA):20 I '$T Q "1^Another user is working with this patient account"
;
; build list of active(16) and open(42) bills for patient
; sorted by date bill prepared
F RCSTATUS=16,42 S RCBILLDA=0 F S RCBILLDA=$O(^PRCA(430,"AS",RCDEBTDA,RCSTATUS,RCBILLDA)) Q:'RCBILLDA D
. ; check bill for prepayment
. I $P(^PRCA(430,RCBILLDA,0),"^",2)=26 Q ; ACCOUNTS RECEIVABLE CATEGORY (PREPAYMENT=26)
. ;
. ; checks if payment was via a "170" CS Treasury lockbox transaction ; prca*4.5*301
. ; Ignores bill if bill is NOT a "TCSP" CS bill
. ; else sets as FIRST if designated as bill to be applied, or subsequent in oldest date order
. I CSDEP=170 D Q ; prca*4.5*301
. . I $D(^PRCA(430,"TCSP",RCBILLDA)) D Q ;
. . . I CSBILLDA=RCBILLDA S ^TMP("RCBEPAY",$J,0,RCBILLDA)="" Q
. . . S ^TMP("RCBEPAY",$J,880000000+$P($G(^PRCA(430,RCBILLDA,0)),"^",10),RCBILLDA)=""
. . S ^TMP("RCBEPAY",$J,990000000+$P($G(^PRCA(430,RCBILLDA,0)),"^",10),RCBILLDA)=""
. I $E($G(CSDEP),1,3)'=168,$D(^PRCA(430,"TCSP",RCBILLDA)) Q ;BB prca*4.5*301
. I CSBILLDA=RCBILLDA S ^TMP("RCBEPAY",$J,0,RCBILLDA)="" Q ;PRCA*4.5*322
. S ^TMP("RCBEPAY",$J,+$P($G(^PRCA(430,RCBILLDA,0)),"^",10),RCBILLDA)=""
PROC ;
; loop all the bills for a patients account and keep looping them
; until either there is no more bills or the money paid is zero.
; the bills are looped in case of repayments. if there is money
; left over, this will apply more money to the repayment bills
; instead of creating a prepayment. a prepayment should only be
; created if all bills for the account is collected/closed.
S RCERROR=0
; quit the loop if no money left to apply OR an error occurred OR
; no more bills left to apply payment to
F D I 'RCPAYAMT!(RCERROR)!($O(^TMP("RCBEPAY",$J,""))="") Q
. ; loop the bills by date prepared and apply the payment
. ; quit if no money left to apply OR and error occurred
. S RCDATE="" F S RCDATE=$O(^TMP("RCBEPAY",$J,RCDATE)) Q:RCDATE="" D I 'RCPAYAMT!(RCERROR) Q
. . S RCBILLDA=0 F S RCBILLDA=$O(^TMP("RCBEPAY",$J,RCDATE,RCBILLDA)) Q:'RCBILLDA D I 'RCPAYAMT!(RCERROR) Q
. . . L +^PRCA(430,RCBILLDA):10
. . . I '$T S RCERROR="1^Another user is working with bill "_$P(^PRCA(430,RCBILLDA,0),"^") Q
. . . ;
. . . ; exempt any interest/admin/penalty charges added on or after
. . . ; the payment date
. . . D EXEMPT^RCBECHGE(RCBILLDA,RCPAYDAT)
. . . ;
. . . ; get the repayment amount (if any)
. . . S RCREPAMT=$P($G(^PRCA(430,RCBILLDA,4)),"^",3) I CSDEP=168!(CSDEP=170) S RCREPAMT=0 ;PRCA*4.5*301
. . . ;
. . . ; get the balance of the bill
. . . S X=$G(^PRCA(430,RCBILLDA,7))
. . . S RCBILBAL=$P(X,"^")+$P(X,"^",2)+$P(X,"^",3)+$P(X,"^",4)+$P(X,"^",5)
. . . ; if bill has no balance, chg status = collected/closed
. . . I 'RCBILBAL D Q ;PRCA*4.5*301
. . . . D CHGSTAT^RCBEUBIL(RCBILLDA,22)
. . . . L -^PRCA(430,RCBILLDA)
. . . . K ^TMP("RCBEPAY",$J,RCDATE,RCBILLDA)
. . . ;
. . . ; determine amount to pay
. . . ; if the payment is greater than billed amount, pay billed amount
. . . ; if there is a repayment amount, pay the repayment amount
. . . ; do not allow payment to exceed amount paid
. . . S PAYMENT=RCPAYAMT
. . . I PAYMENT>RCBILBAL S PAYMENT=RCBILBAL
. . . I RCREPAMT S PAYMENT=RCREPAMT I PAYMENT>RCBILBAL S PAYMENT=RCBILBAL
. . . I PAYMENT>RCPAYAMT S PAYMENT=RCPAYAMT
. . . ;
. . . ; apply payment to bill
. . . ; return error if problem adding payment transaction
. . . S RCTRANDA=$$PAYTRAN^RCBEPAY1(RCBILLDA,PAYMENT,RCRECTDA,RCPAYDA,RCPAYDAT)
. . . I 'RCTRANDA L -^PRCA(430,RCBILLDA) S RCERROR="1^"_$P(RCTRANDA,"^",2) Q
. . . ;
. . . ; payment applied to bill, subtract off the payment amount
. . . S RCPAYAMT=RCPAYAMT-$P($G(^PRCA(433,RCTRANDA,1)),"^",5)
. . . ;
. . . ; set the amount processed on the receipt payment
. . . D SETAMT^RCBEPAY(RCRECTDA,RCPAYDA,$P($G(^PRCA(433,RCTRANDA,1)),"^",5))
. . . ;
. . . ; if Bill is Cross-Serviced, then create DECREASED ADJUSTMENT for 5B reporting
. . . I $E($G(CSDEP),1,3)=168,$D(^PRCA(430,"TCSP",RCBILLDA)) D CS5B(RCBILLDA) ; BB prca*4.5*301
. . . I $E($G(CSDEP),1,3)=170,RCBILLDA'=CSBILLDA,$D(^PRCA(430,"TCSP",RCBILLDA)) D CS5B(RCBILLDA) ; BB prca*4.5*301
. . . ;
. . . ; get the new balance of the bill. if it is zero
. . . ; remove it from the tmp global (this will stop the
. . . ; loop if dollars are left and no bills are active)
. . . S X=$G(^PRCA(430,RCBILLDA,7))
. . . S RCBILBAL=$P(X,"^")+$P(X,"^",2)+$P(X,"^",3)+$P(X,"^",4)+$P(X,"^",5)
. . . I 'RCBILBAL D ;PRCA*4.5*301
. . . . D CHGSTAT^RCBEUBIL(RCBILLDA,22)
. . . . K ^TMP("RCBEPAY",$J,RCDATE,RCBILLDA)
. . . . I $D(^PRCA(430,"TCSP",RCBILLDA)),RCBILLDA=CSBILLDA S $P(^PRCA(430,RCBILLDA,15),"^")="" K ^PRCA(430,"TCSP",RCBILLDA) ;S DA=RCBILLDA,DIE="^PRCA(430,",DR="151////@" D ^DIE K DIE,DA,DR
. . . ;
. . . L -^PRCA(430,RCBILLDA)
;
K ^TMP("RCBEPAY",$J)
;
; if an error occurred, quit
I RCERROR L -^RCD(340,RCDEBTDA) Q RCERROR
;
; if no money left, quit
I 'RCPAYAMT L -^RCD(340,RCDEBTDA) Q 0
;
; dollars remaining, create a prepayment
N %,%H,%I,%X,D,D0,DFN,DI,DIC,DICR,DIG,DIH,DIU,DIV,DIW,DQ,I,PRCA,RCREF,VA,VADM
D EN^PRCAPAY3(RCACCT,RCPAYAMT,RCPAYDAT,DUZ,$P(^RCY(344,RCRECTDA,0),"^"),"","",.RCERROR,"")
; no errors
I RCERROR=""!(RCERROR=0) D
. S RCERROR=0
. ; set the amount processed on the receipt
. D SETAMT^RCBEPAY(RCRECTDA,RCPAYDA,RCPAYAMT)
; error creating prepayment
I RCERROR'=0 S RCERROR="1^"_RCERROR
;
L -^RCD(340,RCDEBTDA)
Q RCERROR
;
CS5B(RCBILLDA) ; logs ADJ for 5B CS reporting if Cross-Serviced bill ; prca*4.5*301 ; LEG
; Changed description from DEC ADJ to ADJ since increase adjustments will also use this code 315/DRF
; note: can use either I +$G(^PRCA(430,RCBILLDA,15)) D ; bill is Cross-Serviced
I $D(^PRCA(430,"TCSP",RCBILLDA)) D ; bill is Cross-Serviced
. ; checks for valid bill
. S DIC="^PRCA(430,",DIC(0)="KMNZ",X=RCBILLDA D ^DIC
. ; checks if DEC ADJ record was previously logged
. S IDX=0,PREV=0
. F S IDX=$O(^PRCA(430,RCBILLDA,17,IDX)) Q:'IDX D ;
. . I +$G(^PRCA(430,RCBILLDA,17,IDX,0))=RCTRANDA S PREV=1
. I PREV Q ; transaction was already logged
. ;
. ; gets next ADJ subfile entry number or creates 1st
. K DR,DA,DD,DO,DIC,DIE
. S X=RCTRANDA ; CS ADJ TRANS NUMBER
. S DA(1)=RCBILLDA
. S DIC="^PRCA(430,"_DA(1)_",17,"
. S DIC(0)="KLMNZ"
. S DIC("P")=$P(^DD(430,171,0),"^",2)
. D ^DIC
. ; set ADJ Fields
. S DIE=DIC K DIC
. S DA=+Y
. S DR="1////1" ; SEND TCSP RECORD 5B
. S DIC("DR")=DR
. D ^DIE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCBEPAYF 8189 printed Apr 09, 2024@20:48:27 Page 2
RCBEPAYF ;WISC/RFJ-first party payment processing(called by rcbepay) ;1 Jun 00
+1 ;;4.5;Accounts Receivable;**153,301,322,315**;Mar 20, 1995;Build 67
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;PRCA*4.5*322 Awaken commented line to post payemnt to
+6 ; implied bill# for receipt payment
+7 ;
FIRSTPTY() ; apply payment to first party account
+1 ; called by rcbepay
+2 NEW PAYMENT,RCBILBAL,RCBILLDA,RCDATE,RCDEBTDA,RCERROR,RCREPAMT,RCSTATUS,RCTRANDA,X,CSBILL,CSBILLDA,CSDEP,IDX,PREV
+3 KILL ^TMP("RCBEPAY",$JOB)
+4 ; acc't lookup info BB prca*4.5*301
+5 SET CSBILLDA=+$EXTRACT($PIECE(RCDATA,"^",7),22,99)
SET CSDEP=$PIECE(RCDATA,"^",19)
SET CSBILL=$EXTRACT($PIECE(RCDATA,"^",7),1,3)_"-"_$EXTRACT($PIECE(RCDATA,"^",7),4,10)
+6 ;Default for missing pay type
IF 'CSDEP
SET CSDEP=169
+7 IF $EXTRACT($GET(CSDEP),1,3)=170
SET CSBILLDA=$ORDER(^PRCA(430,"B",CSBILL,0))
+8 IF RCDATA["PRCA(430,"
SET CSBILLDA=+$PIECE(RCDATA,"^",3)
+9 IF CSDEP>167
IF CSDEP<171
SET RCBETYPE=CSDEP
+10 ;end PRCA*4.5*301
+11 ;
+12 ; look up account in debtor file
+13 SET RCDEBTDA=$$DEBT^RCEVUTL(RCACCT)
+14 IF RCDEBTDA<0
QUIT "1^Could not add Patient ("_RCACCT_") to debtor file"
+15 ;
+16 ; lock the debtor account
+17 LOCK +^RCD(340,RCDEBTDA):20
IF '$TEST
QUIT "1^Another user is working with this patient account"
+18 ;
+19 ; build list of active(16) and open(42) bills for patient
+20 ; sorted by date bill prepared
+21 FOR RCSTATUS=16,42
SET RCBILLDA=0
FOR
SET RCBILLDA=$ORDER(^PRCA(430,"AS",RCDEBTDA,RCSTATUS,RCBILLDA))
if 'RCBILLDA
QUIT
Begin DoDot:1
+22 ; check bill for prepayment
+23 ; ACCOUNTS RECEIVABLE CATEGORY (PREPAYMENT=26)
IF $PIECE(^PRCA(430,RCBILLDA,0),"^",2)=26
QUIT
+24 ;
+25 ; checks if payment was via a "170" CS Treasury lockbox transaction ; prca*4.5*301
+26 ; Ignores bill if bill is NOT a "TCSP" CS bill
+27 ; else sets as FIRST if designated as bill to be applied, or subsequent in oldest date order
+28 ; prca*4.5*301
IF CSDEP=170
Begin DoDot:2
+29 ;
IF $DATA(^PRCA(430,"TCSP",RCBILLDA))
Begin DoDot:3
+30 IF CSBILLDA=RCBILLDA
SET ^TMP("RCBEPAY",$JOB,0,RCBILLDA)=""
QUIT
+31 SET ^TMP("RCBEPAY",$JOB,880000000+$PIECE($GET(^PRCA(430,RCBILLDA,0)),"^",10),RCBILLDA)=""
End DoDot:3
QUIT
+32 SET ^TMP("RCBEPAY",$JOB,990000000+$PIECE($GET(^PRCA(430,RCBILLDA,0)),"^",10),RCBILLDA)=""
End DoDot:2
QUIT
+33 ;BB prca*4.5*301
IF $EXTRACT($GET(CSDEP),1,3)'=168
IF $DATA(^PRCA(430,"TCSP",RCBILLDA))
QUIT
+34 ;PRCA*4.5*322
IF CSBILLDA=RCBILLDA
SET ^TMP("RCBEPAY",$JOB,0,RCBILLDA)=""
QUIT
+35 SET ^TMP("RCBEPAY",$JOB,+$PIECE($GET(^PRCA(430,RCBILLDA,0)),"^",10),RCBILLDA)=""
End DoDot:1
PROC ;
+1 ; loop all the bills for a patients account and keep looping them
+2 ; until either there is no more bills or the money paid is zero.
+3 ; the bills are looped in case of repayments. if there is money
+4 ; left over, this will apply more money to the repayment bills
+5 ; instead of creating a prepayment. a prepayment should only be
+6 ; created if all bills for the account is collected/closed.
+7 SET RCERROR=0
+8 ; quit the loop if no money left to apply OR an error occurred OR
+9 ; no more bills left to apply payment to
+10 FOR
Begin DoDot:1
+11 ; loop the bills by date prepared and apply the payment
+12 ; quit if no money left to apply OR and error occurred
+13 SET RCDATE=""
FOR
SET RCDATE=$ORDER(^TMP("RCBEPAY",$JOB,RCDATE))
if RCDATE=""
QUIT
Begin DoDot:2
+14 SET RCBILLDA=0
FOR
SET RCBILLDA=$ORDER(^TMP("RCBEPAY",$JOB,RCDATE,RCBILLDA))
if 'RCBILLDA
QUIT
Begin DoDot:3
+15 LOCK +^PRCA(430,RCBILLDA):10
+16 IF '$TEST
SET RCERROR="1^Another user is working with bill "_$PIECE(^PRCA(430,RCBILLDA,0),"^")
QUIT
+17 ;
+18 ; exempt any interest/admin/penalty charges added on or after
+19 ; the payment date
+20 DO EXEMPT^RCBECHGE(RCBILLDA,RCPAYDAT)
+21 ;
+22 ; get the repayment amount (if any)
+23 ;PRCA*4.5*301
SET RCREPAMT=$PIECE($GET(^PRCA(430,RCBILLDA,4)),"^",3)
IF CSDEP=168!(CSDEP=170)
SET RCREPAMT=0
+24 ;
+25 ; get the balance of the bill
+26 SET X=$GET(^PRCA(430,RCBILLDA,7))
+27 SET RCBILBAL=$PIECE(X,"^")+$PIECE(X,"^",2)+$PIECE(X,"^",3)+$PIECE(X,"^",4)+$PIECE(X,"^",5)
+28 ; if bill has no balance, chg status = collected/closed
+29 ;PRCA*4.5*301
IF 'RCBILBAL
Begin DoDot:4
+30 DO CHGSTAT^RCBEUBIL(RCBILLDA,22)
+31 LOCK -^PRCA(430,RCBILLDA)
+32 KILL ^TMP("RCBEPAY",$JOB,RCDATE,RCBILLDA)
End DoDot:4
QUIT
+33 ;
+34 ; determine amount to pay
+35 ; if the payment is greater than billed amount, pay billed amount
+36 ; if there is a repayment amount, pay the repayment amount
+37 ; do not allow payment to exceed amount paid
+38 SET PAYMENT=RCPAYAMT
+39 IF PAYMENT>RCBILBAL
SET PAYMENT=RCBILBAL
+40 IF RCREPAMT
SET PAYMENT=RCREPAMT
IF PAYMENT>RCBILBAL
SET PAYMENT=RCBILBAL
+41 IF PAYMENT>RCPAYAMT
SET PAYMENT=RCPAYAMT
+42 ;
+43 ; apply payment to bill
+44 ; return error if problem adding payment transaction
+45 SET RCTRANDA=$$PAYTRAN^RCBEPAY1(RCBILLDA,PAYMENT,RCRECTDA,RCPAYDA,RCPAYDAT)
+46 IF 'RCTRANDA
LOCK -^PRCA(430,RCBILLDA)
SET RCERROR="1^"_$PIECE(RCTRANDA,"^",2)
QUIT
+47 ;
+48 ; payment applied to bill, subtract off the payment amount
+49 SET RCPAYAMT=RCPAYAMT-$PIECE($GET(^PRCA(433,RCTRANDA,1)),"^",5)
+50 ;
+51 ; set the amount processed on the receipt payment
+52 DO SETAMT^RCBEPAY(RCRECTDA,RCPAYDA,$PIECE($GET(^PRCA(433,RCTRANDA,1)),"^",5))
+53 ;
+54 ; if Bill is Cross-Serviced, then create DECREASED ADJUSTMENT for 5B reporting
+55 ; BB prca*4.5*301
IF $EXTRACT($GET(CSDEP),1,3)=168
IF $DATA(^PRCA(430,"TCSP",RCBILLDA))
DO CS5B(RCBILLDA)
+56 ; BB prca*4.5*301
IF $EXTRACT($GET(CSDEP),1,3)=170
IF RCBILLDA'=CSBILLDA
IF $DATA(^PRCA(430,"TCSP",RCBILLDA))
DO CS5B(RCBILLDA)
+57 ;
+58 ; get the new balance of the bill. if it is zero
+59 ; remove it from the tmp global (this will stop the
+60 ; loop if dollars are left and no bills are active)
+61 SET X=$GET(^PRCA(430,RCBILLDA,7))
+62 SET RCBILBAL=$PIECE(X,"^")+$PIECE(X,"^",2)+$PIECE(X,"^",3)+$PIECE(X,"^",4)+$PIECE(X,"^",5)
+63 ;PRCA*4.5*301
IF 'RCBILBAL
Begin DoDot:4
+64 DO CHGSTAT^RCBEUBIL(RCBILLDA,22)
+65 KILL ^TMP("RCBEPAY",$JOB,RCDATE,RCBILLDA)
+66 ;S DA=RCBILLDA,DIE="^PRCA(430,",DR="151////@" D ^DIE K DIE,DA,DR
IF $DATA(^PRCA(430,"TCSP",RCBILLDA))
IF RCBILLDA=CSBILLDA
SET $PIECE(^PRCA(430,RCBILLDA,15),"^")=""
KILL ^PRCA(430,"TCSP",RCBILLDA)
End DoDot:4
+67 ;
+68 LOCK -^PRCA(430,RCBILLDA)
End DoDot:3
IF 'RCPAYAMT!(RCERROR)
QUIT
End DoDot:2
IF 'RCPAYAMT!(RCERROR)
QUIT
End DoDot:1
IF 'RCPAYAMT!(RCERROR)!($ORDER(^TMP("RCBEPAY",$JOB,""))="")
QUIT
+69 ;
+70 KILL ^TMP("RCBEPAY",$JOB)
+71 ;
+72 ; if an error occurred, quit
+73 IF RCERROR
LOCK -^RCD(340,RCDEBTDA)
QUIT RCERROR
+74 ;
+75 ; if no money left, quit
+76 IF 'RCPAYAMT
LOCK -^RCD(340,RCDEBTDA)
QUIT 0
+77 ;
+78 ; dollars remaining, create a prepayment
+79 NEW %,%H,%I,%X,D,D0,DFN,DI,DIC,DICR,DIG,DIH,DIU,DIV,DIW,DQ,I,PRCA,RCREF,VA,VADM
+80 DO EN^PRCAPAY3(RCACCT,RCPAYAMT,RCPAYDAT,DUZ,$PIECE(^RCY(344,RCRECTDA,0),"^"),"","",.RCERROR,"")
+81 ; no errors
+82 IF RCERROR=""!(RCERROR=0)
Begin DoDot:1
+83 SET RCERROR=0
+84 ; set the amount processed on the receipt
+85 DO SETAMT^RCBEPAY(RCRECTDA,RCPAYDA,RCPAYAMT)
End DoDot:1
+86 ; error creating prepayment
+87 IF RCERROR'=0
SET RCERROR="1^"_RCERROR
+88 ;
+89 LOCK -^RCD(340,RCDEBTDA)
+90 QUIT RCERROR
+91 ;
CS5B(RCBILLDA) ; logs ADJ for 5B CS reporting if Cross-Serviced bill ; prca*4.5*301 ; LEG
+1 ; Changed description from DEC ADJ to ADJ since increase adjustments will also use this code 315/DRF
+2 ; note: can use either I +$G(^PRCA(430,RCBILLDA,15)) D ; bill is Cross-Serviced
+3 ; bill is Cross-Serviced
IF $DATA(^PRCA(430,"TCSP",RCBILLDA))
Begin DoDot:1
+4 ; checks for valid bill
+5 SET DIC="^PRCA(430,"
SET DIC(0)="KMNZ"
SET X=RCBILLDA
DO ^DIC
+6 ; checks if DEC ADJ record was previously logged
+7 SET IDX=0
SET PREV=0
+8 ;
FOR
SET IDX=$ORDER(^PRCA(430,RCBILLDA,17,IDX))
if 'IDX
QUIT
Begin DoDot:2
+9 IF +$GET(^PRCA(430,RCBILLDA,17,IDX,0))=RCTRANDA
SET PREV=1
End DoDot:2
+10 ; transaction was already logged
IF PREV
QUIT
+11 ;
+12 ; gets next ADJ subfile entry number or creates 1st
+13 KILL DR,DA,DD,DO,DIC,DIE
+14 ; CS ADJ TRANS NUMBER
SET X=RCTRANDA
+15 SET DA(1)=RCBILLDA
+16 SET DIC="^PRCA(430,"_DA(1)_",17,"
+17 SET DIC(0)="KLMNZ"
+18 SET DIC("P")=$PIECE(^DD(430,171,0),"^",2)
+19 DO ^DIC
+20 ; set ADJ Fields
+21 SET DIE=DIC
KILL DIC
+22 SET DA=+Y
+23 ; SEND TCSP RECORD 5B
SET DR="1////1"
+24 SET DIC("DR")=DR
+25 DO ^DIE
End DoDot:1
+26 QUIT
