ACHSTXP2 ; IHS/ITSC/FCJ - EXPORT PREV DATA (2/2) - RECORD 2(DHR), SET GLOBALS FOR OTHER RECORD TYPES ; [ 10/14/2004 12:53 PM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**11**;JUNE 11, 2001
;3.1*11 IHS/ITSC/FCJ 8.18.04 NEW ROUTINE-ORIGINAL RTN ACHSTX2
; SETS DATE FOR EXPORT: 10.01.01 THRU 09.30.04
;
D LINES^ACHSFU
W @IOF,!,ACHS("*"),!?30,"EXPORT CHS DATA",!,ACHS("*"),!
S ACHSCHSS=""
D ^ACHSUF
K ACHSCHSS
D KILLGLBS^ACHSTX
;ITSC/SET/JVK ACHS*3.1*11 FOR OUR PURPOSE ALL SITES WILL BE 638
;SO THAT NO DHR RECORDS ARE CREATED
;S (J,ACHSDCR)=0,ACHSRR="",ACHSF638=$P(^ACHSF(DUZ(2),0),U,8)
S (J,ACHSDCR)=0,ACHSRR="",ACHSF638="Y"
S ACHSEXP="Y"
S ACHSEDT=3040930,ACHSBDT=3001001
F ACHS=2:1:7 S ACHSRTYP(ACHS)=0
S2 ;export Re-Generation.
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
;I $$PARM^ACHS(2,9)="Y" F ACHS="252F","254V" S ACHS(ACHS)=$O(^ACHS(3,DUZ(2),1,"B",ACHS,0))
I ACHSEXP="Y" F ACHS="252F","254V" S ACHS(ACHS)=$O(^ACHS(3,DUZ(2),1,"B",ACHS,0))
;I ACHSF638="Y",$$PARM^ACHS(2,9)="Y" F ACHS="252G","252R","254D","254L","254M" S ACHS(ACHS)=$O(^ACHS(3,DUZ(2),1,"B",ACHS,0))
I ACHSF638="Y",ACHSEXP="Y" F ACHS="252G","252R","254D","254L","254M" S ACHS(ACHS)=$O(^ACHS(3,DUZ(2),1,"B",ACHS,0))
;
S ACHSBDT=ACHSBDT-1
S3 S ACHSBDT=$O(^ACHSF(DUZ(2),"TB",ACHSBDT))
G CVTEND1:ACHSBDT<1!(ACHSBDT>ACHSEDT)
S:ACHSRCT=0 ACHSFDT=ACHSBDT
S ACHSTY=""
S4 ;
S ACHSTY=$O(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTY))
G S3:ACHSTY="",S4:ACHSTY="ZA"!(ACHSTY="IP")
S P=0
S5 ;
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 DA=0
S6 ;
S DA=$O(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTY,P,DA))
;
G S5:DA<1
S ACHSDEST=$P($G(^ACHSF(DUZ(2),"D",P,0)),U,17),ACHSCTY=ACHSTY
G S6:'$D(^ACHSF(DUZ(2),"D",P,"T",DA,0)) S X=$P(^(0),U,4),X=$P(X,".",1)_$E($P(X,".",2)_"00",1,2),ACHSIPA=$E(X+1000000000000,2,13) I ACHSCTY="C" S ACHSCTY=$P(^(0),U,5)
G S6:'$D(^ACHSF(DUZ(2),"D",P,0)) S ACHSDOCR=^(0),ACHSTOS=$P(ACHSDOCR,U,4)
S ACHSDR3=$G(^ACHSF(DUZ(2),"D",P,3),"")
;I ACHSF638="Y",$$PARM^ACHS(2,9)="Y" G S7
I ACHSF638="Y",ACHSEXP="Y" G S7
S:ACHSTY="P"&(ACHSDEST'="F") ^ACHSTXPD(P,DA)=""
S ACHSPROV=$P(^ACHSF(DUZ(2),"D",P,0),U,8)
S:'$D(^ACHSTXVN(ACHSPROV)) ^ACHSTXVN(ACHSPROV)=ACHSDEST
S7 ;
I ACHSDEST="F"!(ACHSTY'="P") G S8
;I $$PARM^ACHS(2,9)'="Y" G S7A
I ACHSEXP'="Y" G S7A
S ^ACHSTXPG(ACHSTOS,P,DA)=""
S7A ;
I ACHSF638'="Y" G S8
S:'$P(ACHSDOCR,U,3) ^ACHSTXPG(ACHSTOS,P,DA)=""
G S6
S8 ;
G S6:ACHSTY="P"
;I ACHSF638="Y",$$PARM^ACHS(2,9)="Y" G S6
I ACHSF638="Y",ACHSEXP="Y" G S6
S ^ACHSTXOB(P,DA)=""
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
S (ACHSX,X1)=$P(ACHSDOCR,U,14)
D FYCVT^ACHSFU
S ACHSXLOC=ACHSFC
S:ACHSY<1987 ACHSXLOC="0"_$E(ACHSFC,2,3)
S ACHSEFDT=$E(DT,4,5)_$E(DT,6,7)_$E(DT,2,3),ACHSCDE=$S(ACHSCTY="I":"05013",ACHSCTY="F":"05024",ACHSCTY="P":"05025",ACHSTY="S":"05015",1:""),ACHSDOCN=0_X1_ACHSXLOC_$P(ACHSDOCR,U),ACHSPROV=$P(ACHSDOCR,U,8)
S:'$D(^ACHSTXVN(ACHSPROV)) ^ACHSTXVN(ACHSPROV)=ACHSDEST
G ERROR^ACHSTX:ACHSCDE=""
D CANOBJ^ACHSTX8
S ACHSFED=$S($P(^AUTTVNDR(ACHSPROV,11),U,10)=2:2,1:1)
S ACHSRCT=ACHSRCT+1 ;RECORD COUNT
S ACHSRTYP(2)=ACHSRTYP(2)+1
S ^ACHSDATA(ACHSRCT)="2"_ACHSEFDT_ACHSCDE_$S(ACHSTOS=1:323,ACHSTOS=2:324,ACHSTOS=3:325,1:"")_ACHSDOCN_$J("",13)_"1"_X1_ACHSCAN_ACHSOBJC_ACHSIPA_ACHSFED_$J("",16)
;
I $L(^ACHSDATA(ACHSRCT))'=80 W !!,*7,*7,"A DHR RECORD WAS PRODUCED THAT WAS NOT 80 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)
D BC
G S6
;
ERR ;
W !!,*7,*7,"DCR REGISTER ERROR YOU MUST CLOSE YOUR REGISTERS FIRST"
D ^%ZISC,KILL^ACHSTX8,RTRN^ACHS
Q
;
AFACERR ;
W !!,*7,*7,"AUTHORIZING FACILITY CODE ERROR - JOB CANCELLED"
D ^%ZISC,KILL^ACHSTX8
Q
;
CVTEND1 ;
S ACHSROUT=ACHSRCT
S:ACHSRCT>2 ACHSROUT=ACHSRCT
K ACHSDEST,ACHSDCR,ACHSF638,ACHSIPA,ACHSCAN,ACHSCDE,ACHSCTY,ACHSDOCN,ACHSDOCR,ACHSEFDT,ACHSPROV,ACHSFED,ACHSOBJC,ACHSTOS,DA,ACHSTY,X1,ACHSXLOC
G ^ACHSTX3
;
BC ;EP - Generate Export records 2B and 2C for CORE.
;
; 2B
S ACHSCAN="IHS/AP:"_$E(ACHSCAN,2,3)_"/SU:"_$E(ACHSCAN,4)_"/YR:"_$E(ACHSCAN,5)_"/CC:"_$E(ACHSCAN,6,7)
S ACHSCAN=ACHSCAN_$J("",30-$L(ACHSCAN))
;
S ACHSOBJC=$E($P($G(^ACHSOCC($P(ACHSDOCR,U,10),0)),U,2),1,20)
S ACHSOBJC=ACHSOBJC_$J("",20-$L(ACHSOBJC))
;
S ACHSX=$P(ACHSDOCR,U,14)
I '$D(ACHSDR3) S ACHSDR3=$S($D(ACHSDIEN):$G(^ACHSF(DUZ(2),"D",ACHSDIEN,3)),1:"")
S ACHSABD=$E($P(ACHSDR3,U,1),4,7)
S ACHSAED=$E($P(ACHSDR3,U,2),4,7)
K ACHSDR3
D FYCVT^ACHSFU
S %="2B"_ACHSFC_"."_ACHSCAN_ACHSOBJC_ACHSY_ACHSABD_ACHSAED
D SET(%)
;
; 2C
; Vendor EIN
S %=$E($P(^AUTTVNDR(ACHSPROV,11),U)_$J("",10),1,10)_$E($P(^AUTTVNDR(ACHSPROV,11),U,2)_" ",1,2)
;
; Vendor Name
S %=%_$E($P(^AUTTVNDR(ACHSPROV,0),U),1,30)
S %=%_$J("",42-$L(%))
;
; 1/8/01 pmf the way this was written, it would crash without
; a vendor address in the database. I'm changing it so that if
; no address is on file, it works. This may backfire - we may
;find out that somebody NEEDS the address and are screwed without
;it. But for now, it's gonna go.
;
; Vendor CityStZip
;S %=%_$P(^AUTTVNDR(ACHSPROV,13),U,2)_","_$P(^DIC(5,$P(^AUTTVNDR(ACHSPROV,13),U,3),0),U,2)_","_$P(^AUTTVNDR(ACHSPROV,13),U,4)
S ACHSVADR=$G(^AUTTVNDR(ACHSPROV,13))
S %=%_$P(ACHSVADR,U,2)_","
S ACHSVAD2=$P(ACHSVADR,U,3) I ACHSVAD2'="" S ACHSVAD2=$P(^DIC(5,ACHSVAD2,0),U,2)
S %=%_ACHSVAD2_","_$P(ACHSVADR,U,4) K ACHSVADR,ACHSVAD2
;
;end of chaNge to allow no address
;
;adjust to 72 characters long
S %=$E(%,1,72),%=%_$J("",72-$L(%))
;
S %="2C"_%
D SET(%)
;
Q
;
SET(%) ;
S %=%_$J("",80-$L(%))
S ACHSRCT=ACHSRCT+1,^ACHSDATA(ACHSRCT)=%
I ACHSRCT#25=0 W $J(ACHSRCT,8)
Q
;
ACHSTXP2 ; IHS/ITSC/FCJ - EXPORT PREV DATA (2/2) - RECORD 2(DHR), SET GLOBALS FOR OTHER RECORD TYPES ; [ 10/14/2004 12:53 PM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**11**;JUNE 11, 2001
+2 ;3.1*11 IHS/ITSC/FCJ 8.18.04 NEW ROUTINE-ORIGINAL RTN ACHSTX2
+3 ; SETS DATE FOR EXPORT: 10.01.01 THRU 09.30.04
+4 ;
+5 DO LINES^ACHSFU
+6 WRITE @IOF,!,ACHS("*"),!?30,"EXPORT CHS DATA",!,ACHS("*"),!
+7 SET ACHSCHSS=""
+8 DO ^ACHSUF
+9 KILL ACHSCHSS
+10 DO KILLGLBS^ACHSTX
+11 ;ITSC/SET/JVK ACHS*3.1*11 FOR OUR PURPOSE ALL SITES WILL BE 638
+12 ;SO THAT NO DHR RECORDS ARE CREATED
+13 ;S (J,ACHSDCR)=0,ACHSRR="",ACHSF638=$P(^ACHSF(DUZ(2),0),U,8)
+14 SET (J,ACHSDCR)=0
SET ACHSRR=""
SET ACHSF638="Y"
+15 SET ACHSEXP="Y"
+16 SET ACHSEDT=3040930
SET ACHSBDT=3001001
+17 FOR ACHS=2:1:7
SET ACHSRTYP(ACHS)=0
S2 ;export Re-Generation.
+1 SET ACHSFDT=ACHSBDT
SET ACHSLDAT=ACHSEDT
SET ACHSAFAC=$PIECE(^AUTTLOC(DUZ(2),0),U,10)
+2 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)
+3 IF +ACHSAFAC<1
GOTO AFACERR
+4 ;I $$PARM^ACHS(2,9)="Y" F ACHS="252F","254V" S ACHS(ACHS)=$O(^ACHS(3,DUZ(2),1,"B",ACHS,0))
+5 IF ACHSEXP="Y"
FOR ACHS="252F","254V"
SET ACHS(ACHS)=$ORDER(^ACHS(3,DUZ(2),1,"B",ACHS,0))
+6 ;I ACHSF638="Y",$$PARM^ACHS(2,9)="Y" F ACHS="252G","252R","254D","254L","254M" S ACHS(ACHS)=$O(^ACHS(3,DUZ(2),1,"B",ACHS,0))
+7 IF ACHSF638="Y"
IF ACHSEXP="Y"
FOR ACHS="252G","252R","254D","254L","254M"
SET ACHS(ACHS)=$ORDER(^ACHS(3,DUZ(2),1,"B",ACHS,0))
+8 ;
+9 SET ACHSBDT=ACHSBDT-1
S3 SET ACHSBDT=$ORDER(^ACHSF(DUZ(2),"TB",ACHSBDT))
+1 IF ACHSBDT<1!(ACHSBDT>ACHSEDT)
GOTO CVTEND1
+2 IF ACHSRCT=0
SET ACHSFDT=ACHSBDT
+3 SET ACHSTY=""
S4 ;
+1 SET ACHSTY=$ORDER(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTY))
+2 IF ACHSTY=""
GOTO S3
IF ACHSTY="ZA"!(ACHSTY="IP")
GOTO S4
+3 SET P=0
S5 ;
+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 DA=0
S6 ;
+1 SET DA=$ORDER(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTY,P,DA))
+2 ;
+3 IF DA<1
GOTO S5
+4 SET ACHSDEST=$PIECE($GET(^ACHSF(DUZ(2),"D",P,0)),U,17)
SET ACHSCTY=ACHSTY
+5 IF '$DATA(^ACHSF(DUZ(2),"D",P,"T",DA,0))
GOTO S6
SET X=$PIECE(^(0),U,4)
SET X=$PIECE(X,".",1)_$EXTRACT($PIECE(X,".",2)_"00",1,2)
SET ACHSIPA=$EXTRACT(X+1000000000000,2,13)
IF ACHSCTY="C"
SET ACHSCTY=$PIECE(^(0),U,5)
+6 IF '$DATA(^ACHSF(DUZ(2),"D",P,0))
GOTO S6
SET ACHSDOCR=^(0)
SET ACHSTOS=$PIECE(ACHSDOCR,U,4)
+7 SET ACHSDR3=$GET(^ACHSF(DUZ(2),"D",P,3),"")
+8 ;I ACHSF638="Y",$$PARM^ACHS(2,9)="Y" G S7
+9 IF ACHSF638="Y"
IF ACHSEXP="Y"
GOTO S7
+10 IF ACHSTY="P"&(ACHSDEST'="F")
SET ^ACHSTXPD(P,DA)=""
+11 SET ACHSPROV=$PIECE(^ACHSF(DUZ(2),"D",P,0),U,8)
+12 IF '$DATA(^ACHSTXVN(ACHSPROV))
SET ^ACHSTXVN(ACHSPROV)=ACHSDEST
S7 ;
+1 IF ACHSDEST="F"!(ACHSTY'="P")
GOTO S8
+2 ;I $$PARM^ACHS(2,9)'="Y" G S7A
+3 IF ACHSEXP'="Y"
GOTO S7A
+4 SET ^ACHSTXPG(ACHSTOS,P,DA)=""
S7A ;
+1 IF ACHSF638'="Y"
GOTO S8
+2 IF '$PIECE(ACHSDOCR,U,3)
SET ^ACHSTXPG(ACHSTOS,P,DA)=""
+3 GOTO S6
S8 ;
+1 IF ACHSTY="P"
GOTO S6
+2 ;I ACHSF638="Y",$$PARM^ACHS(2,9)="Y" G S6
+3 IF ACHSF638="Y"
IF ACHSEXP="Y"
GOTO S6
+4 SET ^ACHSTXOB(P,DA)=""
+5 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
+6 SET (ACHSX,X1)=$PIECE(ACHSDOCR,U,14)
+7 DO FYCVT^ACHSFU
+8 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)
SET ACHSCDE=$SELECT(ACHSCTY="I":"05013",ACHSCTY="F":"05024",ACHSCTY="P":"05025",ACHSTY="S":"05015",1:"")
SET ACHSDOCN=0_X1_ACHSXLOC_$PIECE(ACHSDOCR,U)
SET ACHSPROV=$PIECE(ACHSDOCR,U,8)
+11 IF '$DATA(^ACHSTXVN(ACHSPROV))
SET ^ACHSTXVN(ACHSPROV)=ACHSDEST
+12 IF ACHSCDE=""
GOTO ERROR^ACHSTX
+13 DO CANOBJ^ACHSTX8
+14 SET ACHSFED=$SELECT($PIECE(^AUTTVNDR(ACHSPROV,11),U,10)=2:2,1:1)
+15 ;RECORD COUNT
SET ACHSRCT=ACHSRCT+1
+16 SET ACHSRTYP(2)=ACHSRTYP(2)+1
+17 SET ^ACHSDATA(ACHSRCT)="2"_ACHSEFDT_ACHSCDE_$SELECT(ACHSTOS=1:323,ACHSTOS=2:324,ACHSTOS=3:325,1:"")_ACHSDOCN_$JUSTIFY("",13)_"1"_X1_ACHSCAN_ACHSOBJC_ACHSIPA_ACHSFED_$JUSTIFY("",16)
+18 ;
+19 IF $LENGTH(^ACHSDATA(ACHSRCT))'=80
WRITE !!,*7,*7,"A DHR RECORD WAS PRODUCED THAT WAS NOT 80 CHARACTERS IN LENGTH:",!!,^(ACHSRCT),!,*7,*7
GOTO ERROR^ACHSTX
+20 IF ACHSRCT=1
SET ACHSFDT=ACHSBDT
WRITE !!,"NUMBER OF RECORDS PROCESSED = ",!!
+21 IF ACHSRCT#25=0
WRITE $JUSTIFY(ACHSRCT,8)
+22 DO BC
+23 GOTO S6
+24 ;
ERR ;
+1 WRITE !!,*7,*7,"DCR REGISTER ERROR YOU MUST CLOSE YOUR REGISTERS FIRST"
+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 SET ACHSROUT=ACHSRCT
+2 IF ACHSRCT>2
SET ACHSROUT=ACHSRCT
+3 KILL ACHSDEST,ACHSDCR,ACHSF638,ACHSIPA,ACHSCAN,ACHSCDE,ACHSCTY,ACHSDOCN,ACHSDOCR,ACHSEFDT,ACHSPROV,ACHSFED,ACHSOBJC,ACHSTOS,DA,ACHSTY,X1,ACHSXLOC
+4 GOTO ^ACHSTX3
+5 ;
BC ;EP - Generate Export records 2B and 2C for CORE.
+1 ;
+2 ; 2B
+3 SET ACHSCAN="IHS/AP:"_$EXTRACT(ACHSCAN,2,3)_"/SU:"_$EXTRACT(ACHSCAN,4)_"/YR:"_$EXTRACT(ACHSCAN,5)_"/CC:"_$EXTRACT(ACHSCAN,6,7)
+4 SET ACHSCAN=ACHSCAN_$JUSTIFY("",30-$LENGTH(ACHSCAN))
+5 ;
+6 SET ACHSOBJC=$EXTRACT($PIECE($GET(^ACHSOCC($PIECE(ACHSDOCR,U,10),0)),U,2),1,20)
+7 SET ACHSOBJC=ACHSOBJC_$JUSTIFY("",20-$LENGTH(ACHSOBJC))
+8 ;
+9 SET ACHSX=$PIECE(ACHSDOCR,U,14)
+10 IF '$DATA(ACHSDR3)
SET ACHSDR3=$SELECT($DATA(ACHSDIEN):$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,3)),1:"")
+11 SET ACHSABD=$EXTRACT($PIECE(ACHSDR3,U,1),4,7)
+12 SET ACHSAED=$EXTRACT($PIECE(ACHSDR3,U,2),4,7)
+13 KILL ACHSDR3
+14 DO FYCVT^ACHSFU
+15 SET %="2B"_ACHSFC_"."_ACHSCAN_ACHSOBJC_ACHSY_ACHSABD_ACHSAED
+16 DO SET(%)
+17 ;
+18 ; 2C
+19 ; Vendor EIN
+20 SET %=$EXTRACT($PIECE(^AUTTVNDR(ACHSPROV,11),U)_$JUSTIFY("",10),1,10)_$EXTRACT($PIECE(^AUTTVNDR(ACHSPROV,11),U,2)_" ",1,2)
+21 ;
+22 ; Vendor Name
+23 SET %=%_$EXTRACT($PIECE(^AUTTVNDR(ACHSPROV,0),U),1,30)
+24 SET %=%_$JUSTIFY("",42-$LENGTH(%))
+25 ;
+26 ; 1/8/01 pmf the way this was written, it would crash without
+27 ; a vendor address in the database. I'm changing it so that if
+28 ; no address is on file, it works. This may backfire - we may
+29 ;find out that somebody NEEDS the address and are screwed without
+30 ;it. But for now, it's gonna go.
+31 ;
+32 ; Vendor CityStZip
+33 ;S %=%_$P(^AUTTVNDR(ACHSPROV,13),U,2)_","_$P(^DIC(5,$P(^AUTTVNDR(ACHSPROV,13),U,3),0),U,2)_","_$P(^AUTTVNDR(ACHSPROV,13),U,4)
+34 SET ACHSVADR=$GET(^AUTTVNDR(ACHSPROV,13))
+35 SET %=%_$PIECE(ACHSVADR,U,2)_","
+36 SET ACHSVAD2=$PIECE(ACHSVADR,U,3)
IF ACHSVAD2'=""
SET ACHSVAD2=$PIECE(^DIC(5,ACHSVAD2,0),U,2)
+37 SET %=%_ACHSVAD2_","_$PIECE(ACHSVADR,U,4)
KILL ACHSVADR,ACHSVAD2
+38 ;
+39 ;end of chaNge to allow no address
+40 ;
+41 ;adjust to 72 characters long
+42 SET %=$EXTRACT(%,1,72)
SET %=%_$JUSTIFY("",72-$LENGTH(%))
+43 ;
+44 SET %="2C"_%
+45 DO SET(%)
+46 ;
+47 QUIT
+48 ;
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 ;
