ACRFSSA.m

ACRFSSA ;IHS/OIRM/DSD/THL,AEF - AUXILLIARY SUB-ROUTINES FOR ACRFSS* ROUTINES;  [ 11/01/2001   9:44 AM ]

 ;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001

 ;;AUXILLIARY SUB-ROUTINES FOR ACRFSS* ROUTINES

EXIT ;EP;

 K ACRSS,ACRSS1,ACRSS2,ACRQUIT,ACRCC,ACRCCDA,ACRITMDA,ACRKW,ACRVENO,ACRVENDA,ACRVENAM,ACRNEW,ACRCHK,ACRDSC1,ACRDSC2,ACRJ,ACRNDC,ACRNOW,ACRNSN,ACROBJ,ACROBJDA,ACROCDA,ACRORDNO,ACRSSDA,ACRSSDS1,ACROB

 K ACRSSIT,ACRSSITM,ACRSSORD,ACRSSQA,ACRXCUT,ACRDOCVN,ACRITMNO,ACRVENNM,ACRSSTOT,ACRSSUNT,ACRSSUP,ACRUC,ACRUI,ACRVENON,ACRSS3,ACRSSDS2,ACRSSDS3,ACRSSDS4,ACRSSDS5

 Q

EXITSS4 ;EP;

 K ACRTV,ACRTV1,ACRTVDA,ACRTVDAT,ACRTVDAY,ACRTVCIT,ACRTVLV,ACRTVAR,ACRYY,ACRTVPD,ACRTVLDG,ACRTVMLS,ACRTVPHN,ACRTVTAX,ACRTVOTH,ACRTOT,ACRADV,ACRDA,ACRI,ACRQUIT,ACRTVMR,ACRTVDT,ACRD,ACRNEW,ACRCHANG,ACRDAYS,ACRAIRP,ACRAIRPT,ACRAIRT

 K ACRMR,ACRTAX,ACRPHN,ACROTH,ACRMRR,ACRTVEXP,ACRTVRC,ACRPMRR,ACRTVPML

 Q

FACTOR ;EP;TO CALCULATE PER DIEM FACTOR - CALLED FROM FILEMAN TEMPLATE

 I $D(DA),'$D(ACRDOCDA) S ACRDOCDA=$P(^ACRTV(DA,0),U,2)

 S ACRTVLR=$P(^ACRDOC(ACRDOCDA,"TO"),U,9)

 S ACRPAYP=$P($G(^ACRAU(+ACRTVLR,1)),U,3)

 S ACRX=X

 N X,Y,ACRL,ACRA

 K ACRFACTR

 S Y=$P(^ACRTV(DA,"DT"),U,2)

 I Y="" S ACRL=""

 E  X ^DD("DD") S ACRL=$P(Y,"@",2)

 S Y=$P(^ACRTV(DA,"DT"),U,3)

 I Y="" S ACRA=""

 E  X ^DD("DD") S ACRA=$P(Y,"@",2)

 I ACRL]"" D

 .S ACRL=$S($E(ACRL)'=0:ACRL,1:$E(ACRL,2,5))

 .S ACRL=$P(ACRL,":")_"."_$P(ACRL,":",2)

 I ACRA]"" D

 .S ACRA=$S($E(ACRA)'=0:ACRA,1:$E(ACRA,2,5))

 .S ACRA=$P(ACRA,":")_"."_$P(ACRA,":",2)

 S:ACRL]"" ACRFACTR=$S(ACRL>18:.25,ACRL>12:.5,ACRL>6:.75,1:1)

 S:'$D(ACRFACTR) ACRFACTR=1

 S:ACRA]"" ACRFACTR=ACRFACTR-$S(ACRA>18:0,ACRA>12:.25,ACRA>6:.5,1:.75)

 I ACRL]"",ACRA]"",ACRA-ACRL>11.9 S ACRFACTR=.75

 I ACRL]"",ACRA]"",ACRA-ACRL<12 S ACRFACTR=0

 I ACRFACTR<.75 S ACRFACTR=.75

 I ACRFACTR=1,+^ACRTV(DA,0)=1 S ACRFACTR=.75

 K ACRTVLR,ACRPAYP

 S ACRPD=$P(^ACRPD($P(^ACRTV(DA,"DT"),U,4),0),U,4)

 S:ACRPD="" ACRPD=$P($G(^ACRSYS(1,"DT")),U,22)

 S ACRFACTR=$S('$D(ACRFACTR):1,ACRFACTR>1:1,1:ACRFACTR)

 S ACRFACTR=ACRPD*ACRFACTR

 S ACRFACTR=$S(ACRX<ACRFACTR:ACRX,1:ACRFACTR)

 S $P(^ACRTV(DA,"DT"),U,5)=ACRFACTR

 K ACRFACTR

 Q

SSCHK ;EP;

 I '$D(^ACRSS(ACRSSDA,"DT")) D

 .S ^ACRSS(ACRSSDA,"DT")=""

 .S ACRSSRQD="Required item data missing."

 F ACR=2,4,5,6 I $D(^ACRSS(ACRSSDA,0)),$P(^(0),U,ACR)=""!(ACR=4&($P(^(0),U,4)="999")) D

 .S ACRSSRQD="Required item data missing."

 .W:$E(IOST,1,2)="C-" *7,*7

 .W !!,$S(ACR=4:"OBJECT CODE",ACR=2:"DOCUMENT REFERENCE",ACR=5:"CAN NUMBER",1:"DEPARTMENT ACCOUNT")," missing"

 .W " from ITEM NO. ",+$G(^ACRSS(ACRSSDA,0))

 I '$D(^ACRSS(ACRSSDA,"DESC"))&'$D(^ACRSS(ACRSSDA,"NMS")) D

 .S ACRSSRQD="Required item data missing."

 .W !!,"Description missing"

 .W " from ITEM NO. ",+$G(^ACRSS(ACRSSDA,0))

 I $D(^ACRSS(ACRSSDA,"DESC")),$P(^("DESC"),U)="" D

 .S ACRSSRQD="Required item data missing."

 .W !!,"Description missing"

 .W " from ITEM NO. ",+$G(^ACRSS(ACRSSDA,0))

 Q

SETSS ;EP;TO SET VARIABLES FOR A SELECTED ITEM

 S ACRSS0=^ACRSS(ACRSSDA,0)

 S ACRSSDT=$G(^ACRSS(ACRSSDA,"DT"))

 S ACRSSDSC=$G(^ACRSS(ACRSSDA,"DESC"))

 S ACRSSNMS=$G(^ACRSS(ACRSSDA,"NMS"))

 S ACRRQD=+ACRSSDT

 S ACRUI=$P(ACRSSDT,U,2)

 S ACRUC=$P(ACRSSDT,U,3)

 S ACRRCD=$P(ACRSSDT,U,5)

 S ACRACP=$P(ACRSSDT,U,6)

 S ACRTP=$P(ACRSSDT,U,7)

 S ACRSSRQ=$P(ACRSS0,U,2)

 S ACRSSPO=$P(ACRSS0,U,7)

 S ACRUNRCD=$P(ACRSSDT,U)-ACRACP

 S ACRUI=$S($D(^ACRUI(+ACRUI,0)):$P(^(0),U),1:"**")

 Q

FEDSTRIP ;EP;TO SET THE FEDSTRIP SERIAL NUMBER FOR EACH ITEM ON A FEDSTRIP

 ;ORDER

 I $P(^ACRDOC(ACRDOCDA,0),U,3)=$P(^ACROBL(ACRDOCDA,0),U,6),DT'=$P(^ACRDOC(ACRDOCDA,0),U,3) D

 .S DA=ACRDOCDA

 .S DIE="^ACRDOC("

 .S DR=".03////"_DT

 .D DIE^ACRFDIC

 D JDATE

 S (X,Y)=0

 F  S X=$O(^ACRSS("J",ACRDOCDA,X)) Q:'X  I $D(^ACRSS(X,0)),$P(^(0),U,14)<1 S Y=Y+1

 Q:Y<1

 S ACRMAX=Y

 S ACRPODA=$P(ACRDOC0,U,8)

 S ACRLBDA=$P(ACRDOC0,U,6)

 S ACRFY=$P(^ACRLOCB(ACRLBDA,"DT"),U)

 S:'$D(^ACRPO(ACRPODA,30,0)) ^ACRPO(ACRPODA,30,0)="^9002199.4301^"

 I '$D(^ACRPO(ACRPODA,30,ACRFY,0))#2 D  Q:+$G(Y)<1

 .S (X,DINUM)=ACRFY

 .S (DA,DA(1))=ACRPODA

 .S DIC="^ACRPO("_ACRPODA_",30,"

 .S DIC(0)="L"

 .D FILE^ACRFDIC

FS L +^ACRPO(ACRPODA,30,ACRFY,0):4

 I $T=1 D  I 1

 .S ACRMIN=$P(^ACRPO(ACRPODA,30,ACRFY,0),U,2)+1

 .S $P(^ACRPO(ACRPODA,30,ACRFY,0),U,2)=ACRMAX+ACRMIN-1

 .L -^ACRPO(ACRPODA,30,ACRFY,0):0

 E  G FS

 S ACRSSDA=0

 F  S ACRSSDA=$O(^ACRSS("J",ACRDOCDA,ACRSSDA)) Q:'ACRSSDA  I $D(^ACRSS(ACRSSDA,0)),$P(^(0),U,14)<1 D FS1

 Q

FS1 S DA=ACRSSDA

 S DIE="^ACRSS("

 S DR=".14////"_ACRMIN

 S ACRMIN=ACRMIN+1

 D DIE^ACRFDIC

 Q

JDATE ;EP;TO SET JULIAN DATE

 S ACRRDATE=$P(^ACRDOC(ACRDOCDA,"PO"),U,12)

 Q:'ACRRDATE

 S X=$E(DT,1,3)_"0101"

 D H^%DTC

 S ACRFY=%H

 S X=ACRRDATE

 D H^%DTC

 S X=%H+1-ACRFY

 S X=$S($L(X)=1:"00"_X,$L(X)=2:"0"_X,1:X)

 S ACRRDATE=X

 S ACR3=$G(^ACRDOC(ACRDOCDA,3))

 S ACR18=$E($P($G(^ACRDOC(ACRDOCDA,18)),U),5,8)

 S X2=$E($P(^ACRDOC(ACRDOCDA,0),U,3),1,3)_"0101"

 S X1=$P(^ACRDOC(ACRDOCDA,0),U,3)+1

 D ^%DTC

 S ACRJDATE=$E($P(^ACRDOC(ACRDOCDA,0),U,3),3)_$E("000",1,3-$L(X))_X

 S ACRFSNUM=$P(ACR3,U,13)

 S ACRFSNUM=$E($P($G(^ACRFSCD(+ACRFSNUM,0)),U,2),3,6)

 S ACRFSNUM=$E("XXXX",1,4-$L(ACRFSNUM))_ACRFSNUM

 I $P(ACR3,U,17)'=1 S ACRFSNUM="FS"_ACRFSNUM_ACRJDATE

 E  S ACRFSNUM="SC"_ACRFSNUM_ACR18

 S DA=ACRDOCDA

 S DIE="^ACRDOC("

 S DR=".26////"_ACRJDATE_";.27////"_ACRFSNUM

 D DIE^ACRFDIC

 K ACRFSNUM

 Q

ACRFSSA   ;IHS/OIRM/DSD/THL,AEF - AUXILLIARY SUB-ROUTINES FOR ACRFSS* ROUTINES;  [ 11/01/2001   9:44 AM ]

 +1       ;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001

 +2       ;;AUXILLIARY SUB-ROUTINES FOR ACRFSS* ROUTINES

EXIT      ;EP;

 +1        KILL ACRSS,ACRSS1,ACRSS2,ACRQUIT,ACRCC,ACRCCDA,ACRITMDA,ACRKW,ACRVENO,ACRVENDA,ACRVENAM,ACRNEW,ACRCHK,ACRDSC1,ACRDSC2,ACRJ,ACRNDC,ACRNOW,ACRNSN,ACROBJ,ACROBJDA,ACROCDA,ACRORDNO,ACRSSDA,ACRSSDS1,ACROB

 +2        KILL ACRSSIT,ACRSSITM,ACRSSORD,ACRSSQA,ACRXCUT,ACRDOCVN,ACRITMNO,ACRVENNM,ACRSSTOT,ACRSSUNT,ACRSSUP,ACRUC,ACRUI,ACRVENON,ACRSS3,ACRSSDS2,ACRSSDS3,ACRSSDS4,ACRSSDS5

 +3        QUIT 

EXITSS4   ;EP;

 +1        KILL ACRTV,ACRTV1,ACRTVDA,ACRTVDAT,ACRTVDAY,ACRTVCIT,ACRTVLV,ACRTVAR,ACRYY,ACRTVPD,ACRTVLDG,ACRTVMLS,ACRTVPHN,ACRTVTAX,ACRTVOTH,ACRTOT,ACRADV,ACRDA,ACRI,ACRQUIT,ACRTVMR,ACRTVDT,ACRD,ACRNEW,ACRCHANG,ACRDAYS,ACRAIRP,ACRAIRPT,ACRAIRT

 +2        KILL ACRMR,ACRTAX,ACRPHN,ACROTH,ACRMRR,ACRTVEXP,ACRTVRC,ACRPMRR,ACRTVPML

 +3        QUIT 

FACTOR    ;EP;TO CALCULATE PER DIEM FACTOR - CALLED FROM FILEMAN TEMPLATE

 +1        IF $DATA(DA)

               IF '$DATA(ACRDOCDA)

                   SET ACRDOCDA=$PIECE(^ACRTV(DA,0),U,2)

 +2        SET ACRTVLR=$PIECE(^ACRDOC(ACRDOCDA,"TO"),U,9)

 +3        SET ACRPAYP=$PIECE($GET(^ACRAU(+ACRTVLR,1)),U,3)

 +4        SET ACRX=X

 +5        NEW X,Y,ACRL,ACRA

 +6        KILL ACRFACTR

 +7        SET Y=$PIECE(^ACRTV(DA,"DT"),U,2)

 +8        IF Y=""

               SET ACRL=""

 +9       IF '$TEST

               XECUTE ^DD("DD")

               SET ACRL=$PIECE(Y,"@",2)

 +10       SET Y=$PIECE(^ACRTV(DA,"DT"),U,3)

 +11       IF Y=""

               SET ACRA=""

 +12      IF '$TEST

               XECUTE ^DD("DD")

               SET ACRA=$PIECE(Y,"@",2)

 +13       IF ACRL]""

               Begin DoDot:1

 +14               SET ACRL=$SELECT($EXTRACT(ACRL)'=0:ACRL,1:$EXTRACT(ACRL,2,5))

 +15               SET ACRL=$PIECE(ACRL,":")_"."_$PIECE(ACRL,":",2)

               End DoDot:1

 +16       IF ACRA]""

               Begin DoDot:1

 +17               SET ACRA=$SELECT($EXTRACT(ACRA)'=0:ACRA,1:$EXTRACT(ACRA,2,5))

 +18               SET ACRA=$PIECE(ACRA,":")_"."_$PIECE(ACRA,":",2)

               End DoDot:1

 +19       IF ACRL]""

               SET ACRFACTR=$SELECT(ACRL>18:.25,ACRL>12:.5,ACRL>6:.75,1:1)

 +20       IF '$DATA(ACRFACTR)

               SET ACRFACTR=1

 +21       IF ACRA]""

               SET ACRFACTR=ACRFACTR-$SELECT(ACRA>18:0,ACRA>12:.25,ACRA>6:.5,1:.75)

 +22       IF ACRL]""

               IF ACRA]""

                   IF ACRA-ACRL>11.9

                       SET ACRFACTR=.75

 +23       IF ACRL]""

               IF ACRA]""

                   IF ACRA-ACRL<12

                       SET ACRFACTR=0

 +24       IF ACRFACTR<.75

               SET ACRFACTR=.75

 +25       IF ACRFACTR=1

               IF +^ACRTV(DA,0)=1

                   SET ACRFACTR=.75

 +26       KILL ACRTVLR,ACRPAYP

 +27       SET ACRPD=$PIECE(^ACRPD($PIECE(^ACRTV(DA,"DT"),U,4),0),U,4)

 +28       IF ACRPD=""

               SET ACRPD=$PIECE($GET(^ACRSYS(1,"DT")),U,22)

 +29       SET ACRFACTR=$SELECT('$DATA(ACRFACTR):1,ACRFACTR>1:1,1:ACRFACTR)

 +30       SET ACRFACTR=ACRPD*ACRFACTR

 +31       SET ACRFACTR=$SELECT(ACRX<ACRFACTR:ACRX,1:ACRFACTR)

 +32       SET $PIECE(^ACRTV(DA,"DT"),U,5)=ACRFACTR

 +33       KILL ACRFACTR

 +34       QUIT 

SSCHK     ;EP;

 +1        IF '$DATA(^ACRSS(ACRSSDA,"DT"))

               Begin DoDot:1

 +2                SET ^ACRSS(ACRSSDA,"DT")=""

 +3                SET ACRSSRQD="Required item data missing."

               End DoDot:1

 +4        FOR ACR=2,4,5,6

               IF $DATA(^ACRSS(ACRSSDA,0))

                   IF $PIECE(^(0),U,ACR)=""!(ACR=4&($PIECE(^(0),U,4)="999"))

                       Begin DoDot:1

 +5                        SET ACRSSRQD="Required item data missing."

 +6                        IF $EXTRACT(IOST,1,2)="C-"

                               WRITE *7,*7

 +7                        WRITE !!,$SELECT(ACR=4:"OBJECT CODE",ACR=2:"DOCUMENT REFERENCE",ACR=5:"CAN NUMBER",1:"DEPARTMENT ACCOUNT")," missing"

 +8                        WRITE " from ITEM NO. ",+$GET(^ACRSS(ACRSSDA,0))

                       End DoDot:1

 +9        IF '$DATA(^ACRSS(ACRSSDA,"DESC"))&'$DATA(^ACRSS(ACRSSDA,"NMS"))

               Begin DoDot:1

 +10               SET ACRSSRQD="Required item data missing."

 +11               WRITE !!,"Description missing"

 +12               WRITE " from ITEM NO. ",+$GET(^ACRSS(ACRSSDA,0))

               End DoDot:1

 +13       IF $DATA(^ACRSS(ACRSSDA,"DESC"))

               IF $PIECE(^("DESC"),U)=""

                   Begin DoDot:1

 +14                   SET ACRSSRQD="Required item data missing."

 +15                   WRITE !!,"Description missing"

 +16                   WRITE " from ITEM NO. ",+$GET(^ACRSS(ACRSSDA,0))

                   End DoDot:1

 +17       QUIT 

SETSS     ;EP;TO SET VARIABLES FOR A SELECTED ITEM

 +1        SET ACRSS0=^ACRSS(ACRSSDA,0)

 +2        SET ACRSSDT=$GET(^ACRSS(ACRSSDA,"DT"))

 +3        SET ACRSSDSC=$GET(^ACRSS(ACRSSDA,"DESC"))

 +4        SET ACRSSNMS=$GET(^ACRSS(ACRSSDA,"NMS"))

 +5        SET ACRRQD=+ACRSSDT

 +6        SET ACRUI=$PIECE(ACRSSDT,U,2)

 +7        SET ACRUC=$PIECE(ACRSSDT,U,3)

 +8        SET ACRRCD=$PIECE(ACRSSDT,U,5)

 +9        SET ACRACP=$PIECE(ACRSSDT,U,6)

 +10       SET ACRTP=$PIECE(ACRSSDT,U,7)

 +11       SET ACRSSRQ=$PIECE(ACRSS0,U,2)

 +12       SET ACRSSPO=$PIECE(ACRSS0,U,7)

 +13       SET ACRUNRCD=$PIECE(ACRSSDT,U)-ACRACP

 +14       SET ACRUI=$SELECT($DATA(^ACRUI(+ACRUI,0)):$PIECE(^(0),U),1:"**")

 +15       QUIT 

FEDSTRIP  ;EP;TO SET THE FEDSTRIP SERIAL NUMBER FOR EACH ITEM ON A FEDSTRIP

 +1       ;ORDER

 +2        IF $PIECE(^ACRDOC(ACRDOCDA,0),U,3)=$PIECE(^ACROBL(ACRDOCDA,0),U,6)

               IF DT'=$PIECE(^ACRDOC(ACRDOCDA,0),U,3)

                   Begin DoDot:1

 +3                    SET DA=ACRDOCDA

 +4                    SET DIE="^ACRDOC("

 +5                    SET DR=".03////"_DT

 +6                    DO DIE^ACRFDIC

                   End DoDot:1

 +7        DO JDATE

 +8        SET (X,Y)=0

 +9        FOR 

               SET X=$ORDER(^ACRSS("J",ACRDOCDA,X))

               IF 'X

                   QUIT 

               IF $DATA(^ACRSS(X,0))

                   IF $PIECE(^(0),U,14)<1

                       SET Y=Y+1

 +10       IF Y<1

               QUIT 

 +11       SET ACRMAX=Y

 +12       SET ACRPODA=$PIECE(ACRDOC0,U,8)

 +13       SET ACRLBDA=$PIECE(ACRDOC0,U,6)

 +14       SET ACRFY=$PIECE(^ACRLOCB(ACRLBDA,"DT"),U)

 +15       IF '$DATA(^ACRPO(ACRPODA,30,0))

               SET ^ACRPO(ACRPODA,30,0)="^9002199.4301^"

 +16       IF '$DATA(^ACRPO(ACRPODA,30,ACRFY,0))#2

               Begin DoDot:1

 +17               SET (X,DINUM)=ACRFY

 +18               SET (DA,DA(1))=ACRPODA

 +19               SET DIC="^ACRPO("_ACRPODA_",30,"

 +20               SET DIC(0)="L"

 +21               DO FILE^ACRFDIC

               End DoDot:1

               IF +$GET(Y)<1

                   QUIT 

FS         LOCK +^ACRPO(ACRPODA,30,ACRFY,0):4

 +1        IF $TEST=1

               Begin DoDot:1

 +2                SET ACRMIN=$PIECE(^ACRPO(ACRPODA,30,ACRFY,0),U,2)+1

 +3                SET $PIECE(^ACRPO(ACRPODA,30,ACRFY,0),U,2)=ACRMAX+ACRMIN-1

 +4                LOCK -^ACRPO(ACRPODA,30,ACRFY,0):0

               End DoDot:1

               IF 1

 +5       IF '$TEST

               GOTO FS

 +6        SET ACRSSDA=0

 +7        FOR 

               SET ACRSSDA=$ORDER(^ACRSS("J",ACRDOCDA,ACRSSDA))

               IF 'ACRSSDA

                   QUIT 

               IF $DATA(^ACRSS(ACRSSDA,0))

                   IF $PIECE(^(0),U,14)<1

                       DO FS1

 +8        QUIT 

FS1        SET DA=ACRSSDA

 +1        SET DIE="^ACRSS("

 +2        SET DR=".14////"_ACRMIN

 +3        SET ACRMIN=ACRMIN+1

 +4        DO DIE^ACRFDIC

 +5        QUIT 

JDATE     ;EP;TO SET JULIAN DATE

 +1        SET ACRRDATE=$PIECE(^ACRDOC(ACRDOCDA,"PO"),U,12)

 +2        IF 'ACRRDATE

               QUIT 

 +3        SET X=$EXTRACT(DT,1,3)_"0101"

 +4        DO H^%DTC

 +5        SET ACRFY=%H

 +6        SET X=ACRRDATE

 +7        DO H^%DTC

 +8        SET X=%H+1-ACRFY

 +9        SET X=$SELECT($LENGTH(X)=1:"00"_X,$LENGTH(X)=2:"0"_X,1:X)

 +10       SET ACRRDATE=X

 +11       SET ACR3=$GET(^ACRDOC(ACRDOCDA,3))

 +12       SET ACR18=$EXTRACT($PIECE($GET(^ACRDOC(ACRDOCDA,18)),U),5,8)

 +13       SET X2=$EXTRACT($PIECE(^ACRDOC(ACRDOCDA,0),U,3),1,3)_"0101"

 +14       SET X1=$PIECE(^ACRDOC(ACRDOCDA,0),U,3)+1

 +15       DO ^%DTC

 +16       SET ACRJDATE=$EXTRACT($PIECE(^ACRDOC(ACRDOCDA,0),U,3),3)_$EXTRACT("000",1,3-$LENGTH(X))_X

 +17       SET ACRFSNUM=$PIECE(ACR3,U,13)

 +18       SET ACRFSNUM=$EXTRACT($PIECE($GET(^ACRFSCD(+ACRFSNUM,0)),U,2),3,6)

 +19       SET ACRFSNUM=$EXTRACT("XXXX",1,4-$LENGTH(ACRFSNUM))_ACRFSNUM

 +20       IF $PIECE(ACR3,U,17)'=1

               SET ACRFSNUM="FS"_ACRFSNUM_ACRJDATE

 +21      IF '$TEST

               SET ACRFSNUM="SC"_ACRFSNUM_ACR18

 +22       SET DA=ACRDOCDA

 +23       SET DIE="^ACRDOC("

 +24       SET DR=".26////"_ACRJDATE_";.27////"_ACRFSNUM

 +25       DO DIE^ACRFDIC

 +26       KILL ACRFSNUM

 +27       QUIT