BARCLU4 ; IHS/SD/LSL - COLLECTION BATCH PREPAYMENTS ;; 07/09/2010
;;1.8;IHS ACCOUNTS RECEIVABLE;**19**;OCT 26, 2005
;;
;
; IHS/SD/TMM 06/18/2010 1.8*Patch 19 (M819), Add Prepayment functionality.
; See work order 3PMS10001
; ------------------------
; BARCLU is a new routine adding Prepayment functionality to collection entry.
; 819_1. Display prepayments not assigned to a batch (^BARCLU,^BARCLU4)
; 819_2. Remove prompt: AUTO PRINT RECEIPT (^BARCLU01)
; 819_3. Prepayment entry ^BARPPY01 (new routine),^BARCLU1,^BARPUTL
; 819_4. Display prepayments matching payment type selected (^BARCLU,^BARCLU4)
; 819_5. Allow user to assign prepayment to batch (^BARCLU,^BARCLU4,^BARCLU01,^BARPUTL,^BARPST1,^BARBLLK)
; 819_6. Print Prepayment Receipt (^BARPPY02) (new routine)
; ********************************************************************* ;
;
;--->New Tag DISPPAY ;M819*ADD*TMM*20100710 (819_1)
DISPPAY ; Display all Prepayments not assigned to a collection batch
D PPCLEAN
I '$D(^BARPPAY(DUZ(2),"F","N")) Q ;there are no unassigned prepayments
W !!!!,"**PAYMENTS EXIST THAT HAVE NOT BEEN BATCHED. PLEASE REVIEW AND ADD TO A COLLECTION BATCH**"
W !!
I BARCLID(2,"I")'="A" Q ;display only if Collection Point BATCH TYPE = ALL TYPES
; "F" = Index
; "N" = Prepayment BATCH FLAG 'N'ot Assigned to batch
S BARCNTPP=0
S BARPMTYP="" F S BARPMTYP=$O(^BARPPAY(DUZ(2),"F","N",BARPMTYP)) Q:BARPMTYP="" D
. S BARPMTDT="" F S BARPMTDT=$O(^BARPPAY(DUZ(2),"F","N",BARPMTYP,BARPMTDT)) Q:'BARPMTDT D
.. S BARPPIEN="" F S BARPPIEN=$O(^BARPPAY(DUZ(2),"F","N",BARPMTYP,BARPMTDT,BARPPIEN)) Q:'BARPPIEN D
... K BARPPAY ;kill array so last DA is not used
... D BARPPAY^BARCLU1(BARPPIEN) ;builds BARPPAY array
... S BARCNTPP=BARCNTPP+1
... S BARPPAMT=$J($FN(BARPPAY(.07),",",2),11) ;credit (payment amount)
... S BARPAYTY=$E(BARPPAY(.03),1,6) ;payment type
... S BARPMTDI=BARPPAY(.02,"I") ;payment date (FM format)
... S BARPMTMM=$E(BARPMTDI,4,5)
... S BARPMTDD=$E(BARPMTDI,6,7)
... S BARPMTYY=$E(BARPMTDI,1,3)+1700
... S BARPMTYY=$E(BARPMTYY,3,4)
... S BARPAYDT=BARPMTMM_"/"_BARPMTDD_"/"_BARPMTYY
... S BARECPT=$E(BARPPAY(.01),1,16) ;receipt number
... S BARPTNM=$E(BARPPAY(.08),1,20) ;patient name
... S BARPPCMT=$E($G(BARPPAY(101,1)),1,9) ;comment line 1
... W !,BARCNTPP,".",?5,BARPPAMT,?17,BARPAYTY,?24,BARPAYDT,?33,BARECPT,?50,BARPTNM,?71,BARPPCMT
W !
D PAZ^BARRUTL ;Press return to continue
K BARPPAY
Q
;
Q
;
;--->New Tag SELPPAY ;M819*ADD*TMM*20100710 (819_4)
SELPPAY ; Display and select prepayments matching selected payment type
;---- 51:EOB 52:CASH 53:CC 55:REFUND 81:CHECK
D PPCLEAN
;M819*DEL*TMM*20100714*** K BARPP,BARPPAY
S BARPMTYP=$S(BARX=52:"CA",BARX=53:"CC",BARX=81:"CK",1:"")
I BARPMTYP="" Q ;Payment Type not defined
;Stop prepayment processing if no unassigned prepayments
I '$D(^BARPPAY(DUZ(2),"F","N",BARPMTYP)) D Q:BARNOPP
. ;Check for Debit Card entries in Prepayment file if batch payment type is Credit Card
. S BARNOPP=1 ;no further checking if not a Credit Card payment type
. Q:BARPMTYP'="CC"
. S BARNOPP=0
. I '$D(^BARPPAY(DUZ(2),"F","N","DB")) S BARNOPP=1 ;check for debit prepayments
I BARPMTYP'="CC" D
. S BARCNTPP=0
. S BARPMTDT="" F S BARPMTDT=$O(^BARPPAY(DUZ(2),"F","N",BARPMTYP,BARPMTDT)) Q:'BARPMTDT D
.. D SELPPAY1 ;display matching prepayments (not Credits and Debits)
I BARPMTYP="CC" D
. S BARCNTPP=0
. W !!
. F BARPMTYP="CC","DB" D
.. S BARPMTDT="" F S BARPMTDT=$O(^BARPPAY(DUZ(2),"F","N",BARPMTYP,BARPMTDT)) Q:'BARPMTDT D
... D SELPPAY1 ;display matching Credit and Debit prepayments
. S BARPMTYP="CC"
W !!
; Prompt for selection
K DIR
S DIR(0)="NAO^1:"_BARCNTPP
S DIR("A")="Select Entry to batch or <Enter> to proceed: "
D ^DIR
Q:$D(DTOUT)!($D(DUOUT))
Q:(Y="")
S BARSELPP=Y ;Line # of selected prepayment item
;
W !!
S BARPPIEN=$G(BARPP(BARSELPP))
S BARPPDAT=$G(BARPP(BARSELPP,BARPPIEN))
S DIR("A",1)="You selected line "_BARSELPP
S DIR("A",2)=" "
S DIR("A",3)=BARSELPP_"."_BARPPDAT
S DIR("A",4)=" "
S DIR("A")="Are you sure this is what you want? "
S DIR("B")="YES"
S DIR(0)="YA"
D ^DIR
I Y<1 G SELPPAY
S BARPPSEL=1 ;Prepayment item selected
D BARPPAY^BARCLU1(BARPPIEN) ;builds BARPPAY array
Q
;
;--->New Tag SELPPAY1 ;M819*ADD*TMM*20100710 (819_4)
SELPPAY1 ; Display and select prepayment for this batch item
; "F" = Index
; "N" = Prepayment BATCH FLAG 'N'ot Assigned to batch
S BARPPIEN="" F S BARPPIEN=$O(^BARPPAY(DUZ(2),"F","N",BARPMTYP,BARPMTDT,BARPPIEN)) Q:'BARPPIEN D
. K BARPPAY ;kill array so last DA is not used
. D BARPPAY^BARCLU1(BARPPIEN) ;builds BARPPAY array
. S BARCNTPP=BARCNTPP+1
. S BARPPAMT=$J($FN(BARPPAY(.07),",",2),11) ;credit (payment amount)
. S BARPAYTY=$E(BARPPAY(.03),1,6) ;payment type
. S BARPMTDI=BARPPAY(.02,"I") ;payment date (FM format)
. S BARPMTMM=$E(BARPMTDI,4,5)
. S BARPMTDD=$E(BARPMTDI,6,7)
. S BARPMTYY=$E(BARPMTDI,1,3)+1700
. S BARPMTYY=$E(BARPMTYY,3,4)
. S BARPAYDT=BARPMTMM_"/"_BARPMTDD_"/"_BARPMTYY
. S BARECPT=$E(BARPPAY(.01),1,16) ;receipt number
. S BARPTNM=$E(BARPPAY(.08),1,20) ;patient name
. S BARPPCMT=$E($G(BARPPAY(101,1)),1,9) ;comment line 1
. W !,BARCNTPP,".",?5,BARPPAMT,?17,BARPAYTY,?24,BARPAYDT,?33,BARECPT,?50,BARPTNM,?71,BARPPCMT
. S BARPP(BARCNTPP)=BARPPIEN
. S BARPP(BARCNTPP,BARPPIEN)=BARPPAMT_" "_BARPAYTY_" "_BARPAYDT_" "_BARECPT_" "_BARPTNM_" "_BARPPCMT
Q
;
PPUPDT ; Update batch assignment fields in Prepayment file
;--->New Tag PPUPDT ;M819*ADD*TMM*20100710 (819_4)
K DIE,DR,DA
S DR=".14////^S X=BARCLDA" ;BATCH
S DR=DR_";.15////^S X=BARITDA" ;ITEM
D NOW^%DTC
S BARPPDTM=$P(%,".")
S DR=DR_";.16////^S X=BARPPDTM" ;ASSIGNED TO BATCH DT/TM
S DR=DR_";.17////^S X=DUZ" ;ASSIGNED TO BATCH BY USER
; .18 BATCH ASSIGNMENT field update is triggered when field 14 is updated
; Update Pre-Payment file
S DA=BARPPIEN
S DIE=$$DIC^XBDIQ1(90050.06)
D ^DIE
K DIE,DA,DR
;
PPUPDT1 ;Update Prepayment receipt # for batch item
;--->New Tag PPUPDT1 ;M819*ADD*TMM*20100710 (819_4)
S BARDIC="^BARCOL(DUZ(2),"
S DIE=BARDIC_BARCLDA_",1,"
S DA=BARITDA
S DA(1)=BARCLDA
;S DR="23////"_BARPPIEN
S DR="23////^S X=BARPPIEN"
D ^DIE
D PPCLEAN
Q
;
PPCLEAN ; Clear Prepayment variables in Prepayment fields
K BARCNTPP,BARECPT,BARNOPP,BARPAYDT,BARPAYTY,BARPMTDD,BARPMTDI,BARPMTDT
K BARPMTMM,BARPMTYP,BARPMTYY,BARPP,BARPPAMT,BARPPAY,BARPPBDS,BARPPCMT,BARPPDTM
K BARPPIEN,BARPPSEL,BARPTNM,BARSELPP,BARTMPBL,DICB,DICB2,DICB3
Q
;
NEWITEM ;EP setup for auto adding a new item
S X=BARCL(7)+1
S BARCL(7)=X ;last receipt #
S DA(1)=BARCLDA
S DIC="XL"
S DIC("P")=$P(^DD(90051.01,101,0),U,2)
S DIC="^BARCOL(DUZ(2),"_DA(1)_",1,"
S DIC(0)="EXQML"
;
; 3 = Payment Type
; 4 = Date/time Stamp
; 20 = TDN/IPAC
;S DIC("DR")="3///NOW;4////^S X=DUZ" ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
S DIC("DR")="3///NOW;4////^S X=DUZ;20////"_$P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,28) ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
S DINUM=X
K DD,DO
S DLAYGO=90050
K DD,DO
D FILE^DICN
K DLAYGO,DIC("P")
I Y'>0 D Q
. W !!,"error in setting new entry",!!
. D EOP^BARUTL(1)
S BARITDA=+Y
K DR,DIC,DIE,DA
S DA=BARITDA
S DA(1)=BARCLDA
S DIE=BARDIC_BARCLDA_",1,"
Q
; *********************************************************************
BARCLU4 ; IHS/SD/LSL - COLLECTION BATCH PREPAYMENTS ;; 07/09/2010
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**19**;OCT 26, 2005
+2 ;;
+3 ;
+4 ; IHS/SD/TMM 06/18/2010 1.8*Patch 19 (M819), Add Prepayment functionality.
+5 ; See work order 3PMS10001
+6 ; ------------------------
+7 ; BARCLU is a new routine adding Prepayment functionality to collection entry.
+8 ; 819_1. Display prepayments not assigned to a batch (^BARCLU,^BARCLU4)
+9 ; 819_2. Remove prompt: AUTO PRINT RECEIPT (^BARCLU01)
+10 ; 819_3. Prepayment entry ^BARPPY01 (new routine),^BARCLU1,^BARPUTL
+11 ; 819_4. Display prepayments matching payment type selected (^BARCLU,^BARCLU4)
+12 ; 819_5. Allow user to assign prepayment to batch (^BARCLU,^BARCLU4,^BARCLU01,^BARPUTL,^BARPST1,^BARBLLK)
+13 ; 819_6. Print Prepayment Receipt (^BARPPY02) (new routine)
+14 ; ********************************************************************* ;
+15 ;
+16 ;--->New Tag DISPPAY ;M819*ADD*TMM*20100710 (819_1)
DISPPAY ; Display all Prepayments not assigned to a collection batch
+1 DO PPCLEAN
+2 ;there are no unassigned prepayments
IF '$DATA(^BARPPAY(DUZ(2),"F","N"))
QUIT
+3 WRITE !!!!,"**PAYMENTS EXIST THAT HAVE NOT BEEN BATCHED. PLEASE REVIEW AND ADD TO A COLLECTION BATCH**"
+4 WRITE !!
+5 ;display only if Collection Point BATCH TYPE = ALL TYPES
IF BARCLID(2,"I")'="A"
QUIT
+6 ; "F" = Index
+7 ; "N" = Prepayment BATCH FLAG 'N'ot Assigned to batch
+8 SET BARCNTPP=0
+9 SET BARPMTYP=""
FOR
SET BARPMTYP=$ORDER(^BARPPAY(DUZ(2),"F","N",BARPMTYP))
IF BARPMTYP=""
QUIT
Begin DoDot:1
+10 SET BARPMTDT=""
FOR
SET BARPMTDT=$ORDER(^BARPPAY(DUZ(2),"F","N",BARPMTYP,BARPMTDT))
IF 'BARPMTDT
QUIT
Begin DoDot:2
+11 SET BARPPIEN=""
FOR
SET BARPPIEN=$ORDER(^BARPPAY(DUZ(2),"F","N",BARPMTYP,BARPMTDT,BARPPIEN))
IF 'BARPPIEN
QUIT
Begin DoDot:3
+12 ;kill array so last DA is not used
KILL BARPPAY
+13 ;builds BARPPAY array
DO BARPPAY^BARCLU1(BARPPIEN)
+14 SET BARCNTPP=BARCNTPP+1
+15 ;credit (payment amount)
SET BARPPAMT=$JUSTIFY($FNUMBER(BARPPAY(.07),",",2),11)
+16 ;payment type
SET BARPAYTY=$EXTRACT(BARPPAY(.03),1,6)
+17 ;payment date (FM format)
SET BARPMTDI=BARPPAY(.02,"I")
+18 SET BARPMTMM=$EXTRACT(BARPMTDI,4,5)
+19 SET BARPMTDD=$EXTRACT(BARPMTDI,6,7)
+20 SET BARPMTYY=$EXTRACT(BARPMTDI,1,3)+1700
+21 SET BARPMTYY=$EXTRACT(BARPMTYY,3,4)
+22 SET BARPAYDT=BARPMTMM_"/"_BARPMTDD_"/"_BARPMTYY
+23 ;receipt number
SET BARECPT=$EXTRACT(BARPPAY(.01),1,16)
+24 ;patient name
SET BARPTNM=$EXTRACT(BARPPAY(.08),1,20)
+25 ;comment line 1
SET BARPPCMT=$EXTRACT($GET(BARPPAY(101,1)),1,9)
+26 WRITE !,BARCNTPP,".",?5,BARPPAMT,?17,BARPAYTY,?24,BARPAYDT,?33,BARECPT,?50,BARPTNM,?71,BARPPCMT
End DoDot:3
End DoDot:2
End DoDot:1
+27 WRITE !
+28 ;Press return to continue
DO PAZ^BARRUTL
+29 KILL BARPPAY
+30 QUIT
+31 ;
+32 QUIT
+33 ;
+34 ;--->New Tag SELPPAY ;M819*ADD*TMM*20100710 (819_4)
SELPPAY ; Display and select prepayments matching selected payment type
+1 ;---- 51:EOB 52:CASH 53:CC 55:REFUND 81:CHECK
+2 DO PPCLEAN
+3 ;M819*DEL*TMM*20100714*** K BARPP,BARPPAY
+4 SET BARPMTYP=$SELECT(BARX=52:"CA",BARX=53:"CC",BARX=81:"CK",1:"")
+5 ;Payment Type not defined
IF BARPMTYP=""
QUIT
+6 ;Stop prepayment processing if no unassigned prepayments
+7 IF '$DATA(^BARPPAY(DUZ(2),"F","N",BARPMTYP))
Begin DoDot:1
+8 ;Check for Debit Card entries in Prepayment file if batch payment type is Credit Card
+9 ;no further checking if not a Credit Card payment type
SET BARNOPP=1
+10 IF BARPMTYP'="CC"
QUIT
+11 SET BARNOPP=0
+12 ;check for debit prepayments
IF '$DATA(^BARPPAY(DUZ(2),"F","N","DB"))
SET BARNOPP=1
End DoDot:1
IF BARNOPP
QUIT
+13 IF BARPMTYP'="CC"
Begin DoDot:1
+14 SET BARCNTPP=0
+15 SET BARPMTDT=""
FOR
SET BARPMTDT=$ORDER(^BARPPAY(DUZ(2),"F","N",BARPMTYP,BARPMTDT))
IF 'BARPMTDT
QUIT
Begin DoDot:2
+16 ;display matching prepayments (not Credits and Debits)
DO SELPPAY1
End DoDot:2
End DoDot:1
+17 IF BARPMTYP="CC"
Begin DoDot:1
+18 SET BARCNTPP=0
+19 WRITE !!
+20 FOR BARPMTYP="CC","DB"
Begin DoDot:2
+21 SET BARPMTDT=""
FOR
SET BARPMTDT=$ORDER(^BARPPAY(DUZ(2),"F","N",BARPMTYP,BARPMTDT))
IF 'BARPMTDT
QUIT
Begin DoDot:3
+22 ;display matching Credit and Debit prepayments
DO SELPPAY1
End DoDot:3
End DoDot:2
+23 SET BARPMTYP="CC"
End DoDot:1
+24 WRITE !!
+25 ; Prompt for selection
+26 KILL DIR
+27 SET DIR(0)="NAO^1:"_BARCNTPP
+28 SET DIR("A")="Select Entry to batch or <Enter> to proceed: "
+29 DO ^DIR
+30 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+31 IF (Y="")
QUIT
+32 ;Line # of selected prepayment item
SET BARSELPP=Y
+33 ;
+34 WRITE !!
+35 SET BARPPIEN=$GET(BARPP(BARSELPP))
+36 SET BARPPDAT=$GET(BARPP(BARSELPP,BARPPIEN))
+37 SET DIR("A",1)="You selected line "_BARSELPP
+38 SET DIR("A",2)=" "
+39 SET DIR("A",3)=BARSELPP_"."_BARPPDAT
+40 SET DIR("A",4)=" "
+41 SET DIR("A")="Are you sure this is what you want? "
+42 SET DIR("B")="YES"
+43 SET DIR(0)="YA"
+44 DO ^DIR
+45 IF Y<1
GOTO SELPPAY
+46 ;Prepayment item selected
SET BARPPSEL=1
+47 ;builds BARPPAY array
DO BARPPAY^BARCLU1(BARPPIEN)
+48 QUIT
+49 ;
+50 ;--->New Tag SELPPAY1 ;M819*ADD*TMM*20100710 (819_4)
SELPPAY1 ; Display and select prepayment for this batch item
+1 ; "F" = Index
+2 ; "N" = Prepayment BATCH FLAG 'N'ot Assigned to batch
+3 SET BARPPIEN=""
FOR
SET BARPPIEN=$ORDER(^BARPPAY(DUZ(2),"F","N",BARPMTYP,BARPMTDT,BARPPIEN))
IF 'BARPPIEN
QUIT
Begin DoDot:1
+4 ;kill array so last DA is not used
KILL BARPPAY
+5 ;builds BARPPAY array
DO BARPPAY^BARCLU1(BARPPIEN)
+6 SET BARCNTPP=BARCNTPP+1
+7 ;credit (payment amount)
SET BARPPAMT=$JUSTIFY($FNUMBER(BARPPAY(.07),",",2),11)
+8 ;payment type
SET BARPAYTY=$EXTRACT(BARPPAY(.03),1,6)
+9 ;payment date (FM format)
SET BARPMTDI=BARPPAY(.02,"I")
+10 SET BARPMTMM=$EXTRACT(BARPMTDI,4,5)
+11 SET BARPMTDD=$EXTRACT(BARPMTDI,6,7)
+12 SET BARPMTYY=$EXTRACT(BARPMTDI,1,3)+1700
+13 SET BARPMTYY=$EXTRACT(BARPMTYY,3,4)
+14 SET BARPAYDT=BARPMTMM_"/"_BARPMTDD_"/"_BARPMTYY
+15 ;receipt number
SET BARECPT=$EXTRACT(BARPPAY(.01),1,16)
+16 ;patient name
SET BARPTNM=$EXTRACT(BARPPAY(.08),1,20)
+17 ;comment line 1
SET BARPPCMT=$EXTRACT($GET(BARPPAY(101,1)),1,9)
+18 WRITE !,BARCNTPP,".",?5,BARPPAMT,?17,BARPAYTY,?24,BARPAYDT,?33,BARECPT,?50,BARPTNM,?71,BARPPCMT
+19 SET BARPP(BARCNTPP)=BARPPIEN
+20 SET BARPP(BARCNTPP,BARPPIEN)=BARPPAMT_" "_BARPAYTY_" "_BARPAYDT_" "_BARECPT_" "_BARPTNM_" "_BARPPCMT
End DoDot:1
+21 QUIT
+22 ;
PPUPDT ; Update batch assignment fields in Prepayment file
+1 ;--->New Tag PPUPDT ;M819*ADD*TMM*20100710 (819_4)
+2 KILL DIE,DR,DA
+3 ;BATCH
SET DR=".14////^S X=BARCLDA"
+4 ;ITEM
SET DR=DR_";.15////^S X=BARITDA"
+5 DO NOW^%DTC
+6 SET BARPPDTM=$PIECE(%,".")
+7 ;ASSIGNED TO BATCH DT/TM
SET DR=DR_";.16////^S X=BARPPDTM"
+8 ;ASSIGNED TO BATCH BY USER
SET DR=DR_";.17////^S X=DUZ"
+9 ; .18 BATCH ASSIGNMENT field update is triggered when field 14 is updated
+10 ; Update Pre-Payment file
+11 SET DA=BARPPIEN
+12 SET DIE=$$DIC^XBDIQ1(90050.06)
+13 DO ^DIE
+14 KILL DIE,DA,DR
+15 ;
PPUPDT1 ;Update Prepayment receipt # for batch item
+1 ;--->New Tag PPUPDT1 ;M819*ADD*TMM*20100710 (819_4)
+2 SET BARDIC="^BARCOL(DUZ(2),"
+3 SET DIE=BARDIC_BARCLDA_",1,"
+4 SET DA=BARITDA
+5 SET DA(1)=BARCLDA
+6 ;S DR="23////"_BARPPIEN
+7 SET DR="23////^S X=BARPPIEN"
+8 DO ^DIE
+9 DO PPCLEAN
+10 QUIT
+11 ;
PPCLEAN ; Clear Prepayment variables in Prepayment fields
+1 KILL BARCNTPP,BARECPT,BARNOPP,BARPAYDT,BARPAYTY,BARPMTDD,BARPMTDI,BARPMTDT
+2 KILL BARPMTMM,BARPMTYP,BARPMTYY,BARPP,BARPPAMT,BARPPAY,BARPPBDS,BARPPCMT,BARPPDTM
+3 KILL BARPPIEN,BARPPSEL,BARPTNM,BARSELPP,BARTMPBL,DICB,DICB2,DICB3
+4 QUIT
+5 ;
NEWITEM ;EP setup for auto adding a new item
+1 SET X=BARCL(7)+1
+2 ;last receipt #
SET BARCL(7)=X
+3 SET DA(1)=BARCLDA
+4 SET DIC="XL"
+5 SET DIC("P")=$PIECE(^DD(90051.01,101,0),U,2)
+6 SET DIC="^BARCOL(DUZ(2),"_DA(1)_",1,"
+7 SET DIC(0)="EXQML"
+8 ;
+9 ; 3 = Payment Type
+10 ; 4 = Date/time Stamp
+11 ; 20 = TDN/IPAC
+12 ;S DIC("DR")="3///NOW;4////^S X=DUZ" ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
+13 ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
SET DIC("DR")="3///NOW;4////^S X=DUZ;20////"_$PIECE($GET(^BARCOL(DUZ(2),BARCLDA,0)),U,28)
+14 SET DINUM=X
+15 KILL DD,DO
+16 SET DLAYGO=90050
+17 KILL DD,DO
+18 DO FILE^DICN
+19 KILL DLAYGO,DIC("P")
+20 IF Y'>0
Begin DoDot:1
+21 WRITE !!,"error in setting new entry",!!
+22 DO EOP^BARUTL(1)
End DoDot:1
QUIT
+23 SET BARITDA=+Y
+24 KILL DR,DIC,DIE,DA
+25 SET DA=BARITDA
+26 SET DA(1)=BARCLDA
+27 SET DIE=BARDIC_BARCLDA_",1,"
+28 QUIT
+29 ; *********************************************************************
