ACHSTXF ; IHS/OIT/FCJ - EXPORT DATA - RECORD 2(UFMS);
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**13,14,17**;JUN 11,2001
;ACHS*3.1*13 IHS/OIT/FCJ NEW ROUTINE
;This is a daily export, ending date will always be date ran unless it is a re-export.
;
;
D LINES^ACHSFU
W @IOF,!,ACHS("*"),!?30,"EXPORT CHS DATA FOR UFMS",!,ACHS("*"),!
S ACHSCHSS=""
D ^ACHSUF
K ACHSCHSS
D KILLGLBS^ACHSTX
S (J,ACHSDCR,ACHSBDT)=0,(ACHSPEX,ACHSRR)="",ACHSF638=$P(^ACHSF(DUZ(2),0),U,8)
S ACHSEDT=DT
S1 ;Set beginning date AND ein of prev export
S ACHSBDT=$P(^ACHSF(DUZ(2),0),U,14) ;date of last export
S:'ACHSBDT ACHSBDT=$P(^ACHSF(DUZ(2),0),U,13) ;date beg export to UFMS
I 'ACHSBDT G ERR
S:$D(^ACHSTXST("C",ACHSBDT,DUZ(2))) ACHSPEX=$O(^ACHSTXST("C",ACHSBDT,DUZ(2),ACHSPEX))
S ACHSBDT=ACHSBDT-1
;
S2 ;
;Set Facility or Authorizing facility
S ACHSFDT=ACHSBDT,ACHSLDAT=ACHSEDT,ACHSAFAC=$P(^AUTTLOC(DUZ(2),0),U,10)
I $$PARM^ACHS(2,25)="Y" S X=$P(^ACHSF(DUZ(2),0),U,12) G AFACERR:+X<1 S ACHSAFAC=$P(^AUTTLOC(X,0),U,10)
I +ACHSAFAC<1 G AFACERR
S3 ;Begin loop through transaction index
S ACHSBDT=$O(^ACHSF(DUZ(2),"TB",ACHSBDT))
G CVTEND1:ACHSBDT<1!(ACHSBDT>ACHSEDT)
S:ACHSRCT=0 ACHSFDT=ACHSBDT
S ACHSTY=""
S4 ;skip pay documents
S ACHSTY=$O(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTY))
G S3:ACHSTY="",S4:ACHSTY="ZA"!(ACHSTY="IP")!(ACHSTY="P")
S P=0
S5 ;Skip special transaction documents
S P=$O(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTY,P))
G S4:P<1,S5:$P(^ACHSF(DUZ(2),"D",P,0),U,3)=2
S (ACHSDOCR,ACHSDOCN,ACHSDOCT,ACHSIPA,ACHSDEST,ACHSCTY,ACHSDR3,ACHSTOS,ACHSDFY,X1)=""
S (ACHSXLOC,ACHSCDE,ACHSARCO,ACHSPROV,ACHSFED,ACHSEIN,ACHSDUNS,ACHSCTYP,ACHS2FY)=""
S DA=0
S6 ;
S ACHSSKIP="" ;ACHS*3.1*14 11/1/2008 IHS/OIT/FCJ
S DA=$O(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTY,P,DA))
G S5:DA<1
G S6:'$D(^ACHSF(DUZ(2),"D",P,0)) S ACHSDOCR=^(0)
G S6:'$D(^ACHSF(DUZ(2),"D",P,"T",DA,0)) S ACHSDOCT=^(0)
;test has transaction been previously sent, because no longer based on DCR
;ACHS*3.1*14 11/1/2008 IHS/OIT/FCJ CHANGED NXT SECTION BECAUSE NOT TESTING FOR TRANSACTION
;I ACHSPEX,$G(^ACHSTXST(DUZ(2),1,ACHSPEX,2,"B",P,DA)) G S6
I ACHSPEX,$D(^ACHSTXST(DUZ(2),1,ACHSPEX,2,"B",P)) D
.S Y=0 F S Y=$O(^ACHSTXST(DUZ(2),1,ACHSPEX,2,"B",P,Y)) Q:Y'?1N.N D Q:ACHSSKIP
..I $P(^ACHSTXST(DUZ(2),1,ACHSPEX,2,Y,0),U,2)=DA S ACHSSKIP=1
G:ACHSSKIP S6
S7 ;EP; FROM RE-EXPORT SINGLE TRANSACTIONS OR BATCHES - ACHSTXF1
S X=$P(ACHSDOCT,U,4),X=$P(X,".")_$E($P(X,".",2)_"00",1,2),ACHSIPA=$E(X+1000000000000,2,13)
S ACHSDEST=$P(ACHSDOCR,U,17),ACHSCTY=ACHSTY
I ACHSCTY="C" S ACHSCTY=$P(ACHSDOCT,U,5) ;full or partial cancel
S ACHSDR3=$G(^ACHSF(DUZ(2),"D",P,3),""),ACHSTOS=$P(ACHSDOCR,U,4)
S ACHSX=$P(ACHSDOCR,U,14) ;FY SINGLE DIGIT USED IN ACHSFU RTN
S ACHSDFY=$P(ACHSDOCR,U,27),X1=$E($P(ACHSDOCR,U,27),4) ;Four digit FY
D FYCVT^ACHSFU
S ACHSXLOC=ACHSFC ;Area finance location code
S:ACHSY<1987 ACHSXLOC="0"_$E(ACHSFC,2,3)
S ACHSEFDT=$E(DT,4,5)_$E(DT,6,7)_$E(DT,2,3)
S ACHSCDE=$S(ACHSCTY="I":"05013",ACHSCTY="F":"05024",ACHSCTY="P":"05025",ACHSCTY="S":"05015",1:"")
S ACHSDOCN=ACHSDFY_ACHSXLOC_$P(ACHSDOCR,U)
S ACHSARCO=$P($G(^ACHSF(DUZ(2),0)),U,11) ;AREA CONTRACTING NO.
S X=$P($G(^ACHSF(DUZ(2),"D",2)),U,9) I X S ACHSCTYP=$P($G(^ACHSCTYP(X,0)),U,2) ;CONTRACT PURCHASE TYPE
S:$L(ACHSCTYP)=0 ACHSCTYP=" "
G ERROR^ACHSTX:ACHSCDE=""
D CANOBJ^ACHSTX8
S ACHSPROV=$P(ACHSDOCR,U,8)
S ACHSFED=$P(^AUTTVNDR(ACHSPROV,11),U,10) S:ACHSFED="" ACHSFED=" "
S ACHSEIN=$TR($P(^AUTTVNDR(ACHSPROV,11),U,13)," -,+","")
I ACHSEIN="" S ACHSEIN=$TR($P(^AUTTVNDR(ACHSPROV,11),U)_$P(^AUTTVNDR(ACHSPROV,11),U,2)," -,+","")
S X=$L(ACHSEIN) I X'=12 F I=1:1:12-X S ACHSEIN=" "_ACHSEIN
S ACHSDUNS=$P(^AUTTVNDR(ACHSPROV,0),U,7) S X=$L(ACHSDUNS) I X'=13 F I=1:1:13-X S ACHSDUNS=ACHSDUNS_" "
S8 ;
;ACHS*3.1*17 1.9.2010 IHS.OIT.FCJ ADDED NXT 2 LNE-SENDING BUDGET FY, 2ND LINE TEST FOR START DT BECAUSE OF DOC ALREADY SENT
S ACHS2FY=$E(ACHSCFY,3,4)
I $P(^ACHSF(DUZ(2),0),U,16)'="",$P(ACHSDOCR,U,2)<$P(^ACHSF(DUZ(2),0),U,16) S ACHS2FY=$E(ACHSDFY,3,4)
S ACHSRCT=ACHSRCT+1 ;RECORD COUNT
S ACHSRTYP(8)=ACHSRTYP(8)+1
S ^ACHSDATA(ACHSRCT)="U2"_ACHSEFDT_ACHSCDE_$S(ACHSTOS=1:323,ACHSTOS=2:324,ACHSTOS=3:325,1:"")_"HHSI"_ACHSARCO_ACHSDOCN_ACHSCTYP_$J("",3)_"1"_X1
;ACHS*3.1*17 1.9.2010 IHS.OIT.FCJ MOD NXT LINE TO SEND BUD FY
;S ^ACHSDATA(ACHSRCT)=^ACHSDATA(ACHSRCT)_ACHSCAN_ACHSOBJC_ACHSIPA_ACHSFED_ACHSEIN_$J("",54)_$E(ACHSDFY,3,4)_ACHSDEST_" "_ACHSXLOC_ACHSDUNS_$J("",10)
S ^ACHSDATA(ACHSRCT)=^ACHSDATA(ACHSRCT)_ACHSCAN_ACHSOBJC_ACHSIPA_ACHSFED_ACHSEIN_$J("",54)_ACHS2FY_ACHSDEST_" "_ACHSXLOC_ACHSDUNS_$J("",10)
;
I $L(^ACHSDATA(ACHSRCT))'=161 W !!,*7,*7,"A DHR RECORD WAS PRODUCED THAT WAS NOT 161 CHARACTERS IN LENGTH:",!!,^(ACHSRCT),!,*7,*7 G ERROR^ACHSTX
I ACHSRCT=1 S ACHSFDT=ACHSBDT W !!,"NUMBER OF RECORDS PROCESSED = ",!!
I ACHSRCT#25=0 W $J(ACHSRCT,8)
I ACHSDEST="F" D
.I +$P(ACHSDOCR,U,22),+$P(ACHSDOCR,U,20),+$P(ACHSDOCR,U,21) S ^ACHSTXPT(+$P(ACHSDOCR,U,22),+$P(ACHSDOCR,U,20),+$P(ACHSDOCR,U,21))=ACHSDEST ;SET REC FOR PT REC
.S ^ACHSTXVN(ACHSPROV)=ACHSDEST ;VENDOR DATA
.S ^ACHSTXOB(P,DA)="" ;DOC INFO FOR FI
S ^TMP("ACHSTX",$J,P,DA)=""
I ACHSF638="Y",$$PARM^ACHS(2,9)="Y",'$P(ACHSDOCR,U,3) S ^ACHSTXPG(ACHSTOS,P,DA)="" ;STATISTICAL
S:ACHSTY="P"&(ACHSDEST'="F") ^ACHSTXPD(P,DA)="" ;AREA OFFICE DATA
Q:ACHSREEX ;ACHS*3.1*14 11/1/2008 IHS/OIT/FCJ TEST FOR REEXPORT
G S6
;
ERR ;
W !!,*7,*7,"ERROR THE UFMS EXPORT START DATE MUST BE ENTERED IN THE CHS PARAMETERS"
D ^%ZISC,KILL^ACHSTX8,RTRN^ACHS
Q
;
AFACERR ;
W !!,*7,*7,"AUTHORIZING FACILITY CODE ERROR - JOB CANCELLED"
D ^%ZISC,KILL^ACHSTX8
Q
;
CVTEND1 ;
W $J(ACHSRCT,8)
S ACHSROUT=ACHSRCT
S:ACHSRCT>2 ACHSROUT=ACHSRCT
K ACHSX,ACHSDUNS,X1,ACHSDFY,ACHSXLOC,ACHSCTYP,ACHSFED,ACHSOBJC,ACHSTOS,DA,ACHSTY,ACHSEIN,ACHSSKIP,ACHS2FY
K ACHSDEST,ACHSDCR,ACHSF638,ACHSIPA,ACHSCAN,ACHSCDE,ACHSCTY,ACHSDOCN,ACHSDOCR,ACHSDR3,ACHSDOCT,ACHSEFDT,ACHSPROV
G ^ACHSTX3
Q
;
SET(%) ;
S %=%_$J("",80-$L(%))
S ACHSRCT=ACHSRCT+1,^ACHSDATA(ACHSRCT)=%
I ACHSRCT#25=0 W $J(ACHSRCT,8)
Q
;
ACHSTXF ; IHS/OIT/FCJ - EXPORT DATA - RECORD 2(UFMS);
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**13,14,17**;JUN 11,2001
+2 ;ACHS*3.1*13 IHS/OIT/FCJ NEW ROUTINE
+3 ;This is a daily export, ending date will always be date ran unless it is a re-export.
+4 ;
+5 ;
+6 DO LINES^ACHSFU
+7 WRITE @IOF,!,ACHS("*"),!?30,"EXPORT CHS DATA FOR UFMS",!,ACHS("*"),!
+8 SET ACHSCHSS=""
+9 DO ^ACHSUF
+10 KILL ACHSCHSS
+11 DO KILLGLBS^ACHSTX
+12 SET (J,ACHSDCR,ACHSBDT)=0
SET (ACHSPEX,ACHSRR)=""
SET ACHSF638=$PIECE(^ACHSF(DUZ(2),0),U,8)
+13 SET ACHSEDT=DT
S1 ;Set beginning date AND ein of prev export
+1 ;date of last export
SET ACHSBDT=$PIECE(^ACHSF(DUZ(2),0),U,14)
+2 ;date beg export to UFMS
IF 'ACHSBDT
SET ACHSBDT=$PIECE(^ACHSF(DUZ(2),0),U,13)
+3 IF 'ACHSBDT
GOTO ERR
+4 IF $DATA(^ACHSTXST("C",ACHSBDT,DUZ(2)))
SET ACHSPEX=$ORDER(^ACHSTXST("C",ACHSBDT,DUZ(2),ACHSPEX))
+5 SET ACHSBDT=ACHSBDT-1
+6 ;
S2 ;
+1 ;Set Facility or Authorizing facility
+2 SET ACHSFDT=ACHSBDT
SET ACHSLDAT=ACHSEDT
SET ACHSAFAC=$PIECE(^AUTTLOC(DUZ(2),0),U,10)
+3 IF $$PARM^ACHS(2,25)="Y"
SET X=$PIECE(^ACHSF(DUZ(2),0),U,12)
IF +X<1
GOTO AFACERR
SET ACHSAFAC=$PIECE(^AUTTLOC(X,0),U,10)
+4 IF +ACHSAFAC<1
GOTO AFACERR
S3 ;Begin loop through transaction index
+1 SET ACHSBDT=$ORDER(^ACHSF(DUZ(2),"TB",ACHSBDT))
+2 IF ACHSBDT<1!(ACHSBDT>ACHSEDT)
GOTO CVTEND1
+3 IF ACHSRCT=0
SET ACHSFDT=ACHSBDT
+4 SET ACHSTY=""
S4 ;skip pay documents
+1 SET ACHSTY=$ORDER(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTY))
+2 IF ACHSTY=""
GOTO S3
IF ACHSTY="ZA"!(ACHSTY="IP")!(ACHSTY="P")
GOTO S4
+3 SET P=0
S5 ;Skip special transaction documents
+1 SET P=$ORDER(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTY,P))
+2 IF P<1
GOTO S4
IF $PIECE(^ACHSF(DUZ(2),"D",P,0),U,3)=2
GOTO S5
+3 SET (ACHSDOCR,ACHSDOCN,ACHSDOCT,ACHSIPA,ACHSDEST,ACHSCTY,ACHSDR3,ACHSTOS,ACHSDFY,X1)=""
+4 SET (ACHSXLOC,ACHSCDE,ACHSARCO,ACHSPROV,ACHSFED,ACHSEIN,ACHSDUNS,ACHSCTYP,ACHS2FY)=""
+5 SET DA=0
S6 ;
+1 ;ACHS*3.1*14 11/1/2008 IHS/OIT/FCJ
SET ACHSSKIP=""
+2 SET DA=$ORDER(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTY,P,DA))
+3 IF DA<1
GOTO S5
+4 IF '$DATA(^ACHSF(DUZ(2),"D",P,0))
GOTO S6
SET ACHSDOCR=^(0)
+5 IF '$DATA(^ACHSF(DUZ(2),"D",P,"T",DA,0))
GOTO S6
SET ACHSDOCT=^(0)
+6 ;test has transaction been previously sent, because no longer based on DCR
+7 ;ACHS*3.1*14 11/1/2008 IHS/OIT/FCJ CHANGED NXT SECTION BECAUSE NOT TESTING FOR TRANSACTION
+8 ;I ACHSPEX,$G(^ACHSTXST(DUZ(2),1,ACHSPEX,2,"B",P,DA)) G S6
+9 IF ACHSPEX
IF $DATA(^ACHSTXST(DUZ(2),1,ACHSPEX,2,"B",P))
Begin DoDot:1
+10 SET Y=0
FOR
SET Y=$ORDER(^ACHSTXST(DUZ(2),1,ACHSPEX,2,"B",P,Y))
IF Y'?1N.N
QUIT
Begin DoDot:2
+11 IF $PIECE(^ACHSTXST(DUZ(2),1,ACHSPEX,2,Y,0),U,2)=DA
SET ACHSSKIP=1
End DoDot:2
IF ACHSSKIP
QUIT
End DoDot:1
+12 IF ACHSSKIP
GOTO S6
S7 ;EP; FROM RE-EXPORT SINGLE TRANSACTIONS OR BATCHES - ACHSTXF1
+1 SET X=$PIECE(ACHSDOCT,U,4)
SET X=$PIECE(X,".")_$EXTRACT($PIECE(X,".",2)_"00",1,2)
SET ACHSIPA=$EXTRACT(X+1000000000000,2,13)
+2 SET ACHSDEST=$PIECE(ACHSDOCR,U,17)
SET ACHSCTY=ACHSTY
+3 ;full or partial cancel
IF ACHSCTY="C"
SET ACHSCTY=$PIECE(ACHSDOCT,U,5)
+4 SET ACHSDR3=$GET(^ACHSF(DUZ(2),"D",P,3),"")
SET ACHSTOS=$PIECE(ACHSDOCR,U,4)
+5 ;FY SINGLE DIGIT USED IN ACHSFU RTN
SET ACHSX=$PIECE(ACHSDOCR,U,14)
+6 ;Four digit FY
SET ACHSDFY=$PIECE(ACHSDOCR,U,27)
SET X1=$EXTRACT($PIECE(ACHSDOCR,U,27),4)
+7 DO FYCVT^ACHSFU
+8 ;Area finance location code
SET ACHSXLOC=ACHSFC
+9 IF ACHSY<1987
SET ACHSXLOC="0"_$EXTRACT(ACHSFC,2,3)
+10 SET ACHSEFDT=$EXTRACT(DT,4,5)_$EXTRACT(DT,6,7)_$EXTRACT(DT,2,3)
+11 SET ACHSCDE=$SELECT(ACHSCTY="I":"05013",ACHSCTY="F":"05024",ACHSCTY="P":"05025",ACHSCTY="S":"05015",1:"")
+12 SET ACHSDOCN=ACHSDFY_ACHSXLOC_$PIECE(ACHSDOCR,U)
+13 ;AREA CONTRACTING NO.
SET ACHSARCO=$PIECE($GET(^ACHSF(DUZ(2),0)),U,11)
+14 ;CONTRACT PURCHASE TYPE
SET X=$PIECE($GET(^ACHSF(DUZ(2),"D",2)),U,9)
IF X
SET ACHSCTYP=$PIECE($GET(^ACHSCTYP(X,0)),U,2)
+15 IF $LENGTH(ACHSCTYP)=0
SET ACHSCTYP=" "
+16 IF ACHSCDE=""
GOTO ERROR^ACHSTX
+17 DO CANOBJ^ACHSTX8
+18 SET ACHSPROV=$PIECE(ACHSDOCR,U,8)
+19 SET ACHSFED=$PIECE(^AUTTVNDR(ACHSPROV,11),U,10)
IF ACHSFED=""
SET ACHSFED=" "
+20 SET ACHSEIN=$TRANSLATE($PIECE(^AUTTVNDR(ACHSPROV,11),U,13)," -,+","")
+21 IF ACHSEIN=""
SET ACHSEIN=$TRANSLATE($PIECE(^AUTTVNDR(ACHSPROV,11),U)_$PIECE(^AUTTVNDR(ACHSPROV,11),U,2)," -,+","")
+22 SET X=$LENGTH(ACHSEIN)
IF X'=12
FOR I=1:1:12-X
SET ACHSEIN=" "_ACHSEIN
+23 SET ACHSDUNS=$PIECE(^AUTTVNDR(ACHSPROV,0),U,7)
SET X=$LENGTH(ACHSDUNS)
IF X'=13
FOR I=1:1:13-X
SET ACHSDUNS=ACHSDUNS_" "
S8 ;
+1 ;ACHS*3.1*17 1.9.2010 IHS.OIT.FCJ ADDED NXT 2 LNE-SENDING BUDGET FY, 2ND LINE TEST FOR START DT BECAUSE OF DOC ALREADY SENT
+2 SET ACHS2FY=$EXTRACT(ACHSCFY,3,4)
+3 IF $PIECE(^ACHSF(DUZ(2),0),U,16)'=""
IF $PIECE(ACHSDOCR,U,2)<$PIECE(^ACHSF(DUZ(2),0),U,16)
SET ACHS2FY=$EXTRACT(ACHSDFY,3,4)
+4 ;RECORD COUNT
SET ACHSRCT=ACHSRCT+1
+5 SET ACHSRTYP(8)=ACHSRTYP(8)+1
+6 SET ^ACHSDATA(ACHSRCT)="U2"_ACHSEFDT_ACHSCDE_$SELECT(ACHSTOS=1:323,ACHSTOS=2:324,ACHSTOS=3:325,1:"")_"HHSI"_ACHSARCO_ACHSDOCN_ACHSCTYP_$JUSTIFY("",3)_"1"_X1
+7 ;ACHS*3.1*17 1.9.2010 IHS.OIT.FCJ MOD NXT LINE TO SEND BUD FY
+8 ;S ^ACHSDATA(ACHSRCT)=^ACHSDATA(ACHSRCT)_ACHSCAN_ACHSOBJC_ACHSIPA_ACHSFED_ACHSEIN_$J("",54)_$E(ACHSDFY,3,4)_ACHSDEST_" "_ACHSXLOC_ACHSDUNS_$J("",10)
+9 SET ^ACHSDATA(ACHSRCT)=^ACHSDATA(ACHSRCT)_ACHSCAN_ACHSOBJC_ACHSIPA_ACHSFED_ACHSEIN_$JUSTIFY("",54)_ACHS2FY_ACHSDEST_" "_ACHSXLOC_ACHSDUNS_$JUSTIFY("",10)
+10 ;
+11 IF $LENGTH(^ACHSDATA(ACHSRCT))'=161
WRITE !!,*7,*7,"A DHR RECORD WAS PRODUCED THAT WAS NOT 161 CHARACTERS IN LENGTH:",!!,^(ACHSRCT),!,*7,*7
GOTO ERROR^ACHSTX
+12 IF ACHSRCT=1
SET ACHSFDT=ACHSBDT
WRITE !!,"NUMBER OF RECORDS PROCESSED = ",!!
+13 IF ACHSRCT#25=0
WRITE $JUSTIFY(ACHSRCT,8)
+14 IF ACHSDEST="F"
Begin DoDot:1
+15 ;SET REC FOR PT REC
IF +$PIECE(ACHSDOCR,U,22)
IF +$PIECE(ACHSDOCR,U,20)
IF +$PIECE(ACHSDOCR,U,21)
SET ^ACHSTXPT(+$PIECE(ACHSDOCR,U,22),+$PIECE(ACHSDOCR,U,20),+$PIECE(ACHSDOCR,U,21))=ACHSDEST
+16 ;VENDOR DATA
SET ^ACHSTXVN(ACHSPROV)=ACHSDEST
+17 ;DOC INFO FOR FI
SET ^ACHSTXOB(P,DA)=""
End DoDot:1
+18 SET ^TMP("ACHSTX",$JOB,P,DA)=""
+19 ;STATISTICAL
IF ACHSF638="Y"
IF $$PARM^ACHS(2,9)="Y"
IF '$PIECE(ACHSDOCR,U,3)
SET ^ACHSTXPG(ACHSTOS,P,DA)=""
+20 ;AREA OFFICE DATA
IF ACHSTY="P"&(ACHSDEST'="F")
SET ^ACHSTXPD(P,DA)=""
+21 ;ACHS*3.1*14 11/1/2008 IHS/OIT/FCJ TEST FOR REEXPORT
IF ACHSREEX
QUIT
+22 GOTO S6
+23 ;
ERR ;
+1 WRITE !!,*7,*7,"ERROR THE UFMS EXPORT START DATE MUST BE ENTERED IN THE CHS PARAMETERS"
+2 DO ^%ZISC
DO KILL^ACHSTX8
DO RTRN^ACHS
+3 QUIT
+4 ;
AFACERR ;
+1 WRITE !!,*7,*7,"AUTHORIZING FACILITY CODE ERROR - JOB CANCELLED"
+2 DO ^%ZISC
DO KILL^ACHSTX8
+3 QUIT
+4 ;
CVTEND1 ;
+1 WRITE $JUSTIFY(ACHSRCT,8)
+2 SET ACHSROUT=ACHSRCT
+3 IF ACHSRCT>2
SET ACHSROUT=ACHSRCT
+4 KILL ACHSX,ACHSDUNS,X1,ACHSDFY,ACHSXLOC,ACHSCTYP,ACHSFED,ACHSOBJC,ACHSTOS,DA,ACHSTY,ACHSEIN,ACHSSKIP,ACHS2FY
+5 KILL ACHSDEST,ACHSDCR,ACHSF638,ACHSIPA,ACHSCAN,ACHSCDE,ACHSCTY,ACHSDOCN,ACHSDOCR,ACHSDR3,ACHSDOCT,ACHSEFDT,ACHSPROV
+6 GOTO ^ACHSTX3
+7 QUIT
+8 ;
SET(%) ;
+1 SET %=%_$JUSTIFY("",80-$LENGTH(%))
+2 SET ACHSRCT=ACHSRCT+1
SET ^ACHSDATA(ACHSRCT)=%
+3 IF ACHSRCT#25=0
WRITE $JUSTIFY(ACHSRCT,8)
+4 QUIT
+5 ;
