ACHSACO1 ; IHS/ITSC/TPF/PMF - AREA CONSOLIDATION (2/3) ;
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**13,23**;JUN 11,2001;Build 43
;ACHS*3.1*13 6.14.2007 IHS/OIT/FCJ ADDED UFMS REC TO REC SUB, REC COUNTER AND TOT
;
A1 ; Initialize counters, main process loop.
;ACHS*3.1*13 IHS/OIT/FCJ ADD UFMS COUNTER IN 2 LINES NXT LINE;ACHS*3.1*23 ADD STAT ICD10 COUNTER
S ACHSCT=+^ACHSPCC("COUNT"),(ACHSCTV,ACHSCTFI,ACHSCTFS,ACHSCTPG,ACHSCTP2,ACHSCTPD,ACHSCTUF)=0
F ACHS=2:1:7,"U" S ACHSTOTL(ACHS)=0
S ACHSCTFI=$G(^ACHSZOCT("BCBS"))
S ACHSCTPD=$G(^ACHSZOCT("AOPD"))
S ACHSCTV=+$P($G(^ACHSAOVU(0)),U)
S ACHSCTPG=$G(^ACHSZOCT("PIG"))
S ACHSCTPG=$G(^ACHSPIG(0,0))
S ACHSCTP2=$G(^ACHSPG2(0,0)) ;ACHS*3.1*23
S ACHSCCOR=$G(^ACHSCORE("COUNT"))
S ACHSCTUF=$G(^ACHSUFMS("COUNT")) ;ACHS*3.1*13 6.14.2007 IHS/OIT/FCJ ADDED COUNTER FOR UFMS REC
S ACHSCTUA=$G(^ACHSUFMS(0)) ;ACHS*3.1*13 6.14.2007 IHS/OIT/FCJ ADDED COUNTER FOR UFMS $
S ACHSCCOR("P")=$$AOP^ACHS(2,2)
U IO(0)
;
W !,"Transferring ",$P(ACHSXD2,U,7)," CHS Data Records..."
W !,"From ",$P($P(IOPAR,":"),"(",2),!!
S DX=$X,DY=$Y
S ACHSCTVS=ACHSCTV+1
;
;adding new var TCOUNT for transaction count. 1/4/01 pmf
;F D Q:$E(X)="*"
F TCOUNT=1:1 D Q:$E(X)="*"
.U IO
.R X:300
.Q:$E(X)="*" ;REACHED EOF MARK -GOOD FILE
.R ACHSX2:300
.;I '($E(ACHSX2)) Q ;ACHS*3.1*13 IHS/OIT/FCJ COMMENTED OUT TO READ "U" TYPE REC
.D T
.S X=+$P($P(X,"(",2),")") ;
.;
.;the next couple of lines is supposed to tell them when
.;every 10 records have been transferred, with a little
.;fancy video stuff. however, the value of X may not be
.;what we need it to be, and the IOXY execution is not
.;working at all, so I'm replacing it.
.;keep these comments until the end of beta testing, just
.;so we keep track of what's going on. 1/4/01 pmf
.;I '(X#10) U IO(0) W X X IOXY
.I TCOUNT#10=0 U IO(0) W TCOUNT," "
;
;REACHED END OF FILE WITH NO BAD RECORDS
D END^ACHSACO2
Q
;
;
T ;
;S ACHSRTYP=+$E(ACHSX2) ;RECORD TYPE
S ACHSRTYP=$E(ACHSX2) ;RECORD TYPE ACHS*3.1*13 IHS/OIT/FCJ Removed "+" TO READ "U" TYPE REC
S ACHSTOTL(ACHSRTYP)=ACHSTOTL(ACHSRTYP)+1 ;COUNT OF RECORD TYPES
S:'$D(ACHSZFAC(ACHSFCPT)) ACHSZFAC(ACHSFCPT)=0 ;FACILITY COUNT
S $P(ACHSZFAC(ACHSFCPT),U)=$P(ACHSZFAC(ACHSFCPT),U)+1
;
;
D T2:ACHSRTYP=2 ;FACILITY GENERATED DHR RECORD
;INCLUDES 638 DENTAL RECORD FOR NPIRS
; BEGINNING WITH '25'
;
D T3:ACHSRTYP=3 ;PATIENT RECORD. INCLUDES 3A, 3B
;AND 3C THIRD PARTY COVERAGE
;
D T4:ACHSRTYP=4 ;VENDOR RECORD. INCLUDES 4A AND 4B
;
D T5:ACHSRTYP=5 ;DOCUMENT (PURCHASE ORDER) RECORD
;INCLUDES 5A AND 5B
;
D T6:ACHSRTYP=6 ;PAYMENT RECORD FOR AREA OFFICE
;INCLUDES 6A AND 6B
;
D T7:ACHSRTYP=7 ;638 STATISTICAL RECORDS FOR NPIRS
;INCLUDES 7A AND 7B
D TU:ACHSRTYP="U" ;UFMS RECORD ;ACHS*3.1*13 IHS/OIT/FCJ Added for UFMS REC
;
;ACHS*3.1*13 IHS/OIT/FCJ ADDED "U" TO NXT LINE
;F ACHSJ=2:1:7 S:ACHSTOTL(ACHSJ)>0 ACHSZFAC(ACHSFCPT,ACHSDRUN,ACHSJ)=ACHSTOTL(ACHSJ)
F ACHSJ=2:1:7,"U" S:ACHSTOTL(ACHSJ)>0 ACHSZFAC(ACHSFCPT,ACHSDRUN,ACHSJ)=ACHSTOTL(ACHSJ)
Q
;
T2 ; FACILITY GENERATED DHR records for HAS and/or CORE.
; For HAS
D ; ALWAYS CREATE THE ACHSPCC GLOBAL FOR TRANSMISSION
. N ACHSSRTY
.;IF SECOND CHAR IS "B" OR "C" THEN OKAY
.;OTHERWISE SET NULL
.S ACHSSRTY=$S("BC"[$E(ACHSX2,2):$E(ACHSX2,2),1:"")
.;I HAVE SEEN THE SECOND CHAR AS A "5" AND A "0"
. I ACHSSRTY="" S ACHSHR1=ACHSX2 ;"20" ????? AND "25" DENTAL RECORDS
.;
. I ACHSSRTY="B" S ACHSHR2=ACHSX2
.;
. I ACHSSRTY="C" D
.. S ACHSCT=ACHSCT+1
.. S ^ACHSPCC(ACHSFACD,ACHSCT)=$$CORE(1)
.. S ACHSCT=ACHSCT+1
.. S ^ACHSPCC(ACHSFACD,ACHSCT)=$$CORE(2)
. S ^ACHSPCC("COUNT")=ACHSCT
;
; For CORE
;I ACHSCCOR("P")'="HAS" S ACHSCCOR=ACHSCCOR+1,^ACHSCORE(ACHSFACD,ACHSCCOR)=ACHSX2,^ACHSCORE("COUNT")=ACHSCCOR
Q
;
T3 ;
;IF WE SHOULD PROCESS FI DATA AND THERE ARE FACILITIES EXPORTING FI DATA
;'PROCESS FI DATA' 'FACILITIES EXPORTING FI DATA'
Q:$$AOP^ACHS(2,3)'="Y"!('$D(^ACHSAOP(DUZ(2),20,ACHSFCPT)))
S ACHSCTFI=ACHSCTFI+1,^ACHSBCBS(ACHSCTFI)=ACHSX2
Q
;
T4 ;
;CHECK TO SEE IF WE SHOULD PROCESS 3RD PARTY COVERAGE TO FI AND WHERE
;'PROCESS FI DATA' 'FACILITIES EXPORTING FI DATA'
G T4A:$$AOP^ACHS(2,3)'="Y"!('$D(^ACHSAOP(DUZ(2),20,ACHSFCPT)))
S ACHSCTFI=ACHSCTFI+1,^ACHSBCBS(ACHSCTFI)=ACHSX2
T4A ;
;CHECK TO SEE IF WE SHOULD PROCESS AREA OFFICE DATA
;'PROCESS AREA OFFICE DATA'
Q:$$AOP^ACHS(2,4)'="Y"
S ACHSCTV=ACHSCTV+1,^ACHSAOVU(ACHSCTV)=ACHSX2
Q
;
T5 ;'PROCESS FI DATA' 'FACILITIES EXPORTING FI DATA'
I $$AOP^ACHS(2,3)="Y",$D(^ACHSAOP(DUZ(2),20,ACHSFCPT)) S ACHSCTFI=ACHSCTFI+1,^ACHSBCBS(ACHSCTFI)=ACHSX2
D SVRSUB:$D(^ACHSAOP(DUZ(2),21)) ;IF 'SPECIAL REPORT VENDORS'
Q
;
T6 ;'PROCESS AREA OFFICE DATA'
Q:$$AOP^ACHS(2,4)'="Y"
S ACHSCTPD=ACHSCTPD+1,^ACHSAOPD(ACHSCTPD)=ACHSX2
Q
;
T7 ; Statistical records.
;ACHS*3.1*23 ADDED TEST FOR NEW STAT RECORD.
I ACHSSTV="CRV003" D
.S ACHSCTP2=ACHSCTP2+1
.I $E(ACHSX2,1,2)="7A" S ACHSSTYP=$E(ACHSX2,3,4)
.S ^ACHSPG2(ACHSSTYP,ACHSFACD,ACHSCTP2)=ACHSX2
E D
.S ACHSCTPG=ACHSCTPG+1
.I $E(ACHSX2,1,2)="7A" S ACHSSTYP=$E(ACHSX2,3,4)
.S ^ACHSPIG(ACHSSTYP,ACHSFACD,ACHSCTPG)=ACHSX2
Q
TU ; UFMS Record ;ACHS*3.1*13 IHS/OIT/FCJ ADDED FOR PROCESSING UFMS RECORD
Q:$E(ACHSX2,1,2)'="U2"
S ACHSCTUF=ACHSCTUF+1
S ^ACHSUFMS(ACHSCTUF)=$E(ACHSX2,2,161)
S ACHSCTUA=ACHSCTUA+$E(ACHSX2,53,64)
Q
;
SVRSUB ; Generate ^ACHSSVR global from 5A & 5B records.
G SVR5A:$E(ACHSX2,1,2)="5A",SVR5B:$E(ACHSX2,1,2)="5B"
Q
;
SVR5A ;
K ACHSX3
S DIC="^AUTTVNDR(",DIC(0)="M",D="C",X=$E(ACHSX2,22,33)
I $E(X,11,12)=" " S X=$E(X,1,10)
D ^DIC
Q:Y<1
Q:'$D(^ACHSAOP(DUZ(2),21,"B",+Y))
S ACHSX3=ACHSX2
S ACHSZFAC=$E(ACHSX2,15,20)
S ACHSEIN=$E(ACHSX2,22,33)
S:$E(ACHSEIN,11,12)=" " ACHSEIN=$E(ACHSEIN,1,10)
S ACHSCTFS=ACHSCTFS+1
S ^ACHSSVR(ACHSEIN,ACHSZFAC,ACHSCTFS)=ACHSX3
Q
;
SVR5B ;
Q:'$D(ACHSX3)
S ACHSX4=ACHSX2
S ^ACHSSVR(ACHSEIN,ACHSZFAC,ACHSCTFS)=ACHSX3_ACHSX4
Q
;
REC(X) ;EP - Return the name of the export record, 1-8.
;CALLED BY ACHSACO2+9 AT END OF REPORT
;ALSO CALLED BY:
; ACHSTX3+4,ACHSTX4+4,ACHSTX5+4,ACHSTX6+4,ACHSTX7+35
; ACHSTX8+6
Q:'$G(X) ""
;ACHS*3.1*13 IHS/OIT/FCJ ADDED UFMS REC TO REC SUB
Q $P("NOT USED^DHR RECORDS FOR HAS/CORE^PATIENT RECORDS FOR AO/FI^VENDOR RECORDS FOR AO/FI^DOCUMENT RECORDS FOR AO/FI^PAYMENT RECORDS FOR AO^STATISTICAL RECORDS^UFMS RECORDS",U,X)
;
;BEGIN CORE MODIFICATIONS ADDITIONAL CODE
CORE(R) ;PROCESS A '2B' RECORD INTO THE 80-160 '2' PART TWO RECORD
I R=1 D
. S ACHSEIN=$E(ACHSX2,3,14)
. S R=$E(ACHSHR1,1,64)_$E(ACHSEIN_$J("",15),1,15)_" "
I R=2 D
. S ACHSF12=$E(ACHSHR2,59,60) ;FISCAL YEAR
. S ACHSF10=$E(ACHSHR2,61,64) ;BEGIN DATE
. S ACHSF11=$E(ACHSHR2,65,68) ;END DATE
. S R=$J("",45)_ACHSF10_ACHSF11_ACHSF12_$J("",25)
. S R=$E(R,1,60)_$$REPEAT^XLFSTR("9",20) ;REQUIRED BY HAS
Q R
;END CORE MODIFICATIONS ADDITIONAL CODE
ACHSACO1 ; IHS/ITSC/TPF/PMF - AREA CONSOLIDATION (2/3) ;
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**13,23**;JUN 11,2001;Build 43
+2 ;ACHS*3.1*13 6.14.2007 IHS/OIT/FCJ ADDED UFMS REC TO REC SUB, REC COUNTER AND TOT
+3 ;
A1 ; Initialize counters, main process loop.
+1 ;ACHS*3.1*13 IHS/OIT/FCJ ADD UFMS COUNTER IN 2 LINES NXT LINE;ACHS*3.1*23 ADD STAT ICD10 COUNTER
+2 SET ACHSCT=+^ACHSPCC("COUNT")
SET (ACHSCTV,ACHSCTFI,ACHSCTFS,ACHSCTPG,ACHSCTP2,ACHSCTPD,ACHSCTUF)=0
+3 FOR ACHS=2:1:7,"U"
SET ACHSTOTL(ACHS)=0
+4 SET ACHSCTFI=$GET(^ACHSZOCT("BCBS"))
+5 SET ACHSCTPD=$GET(^ACHSZOCT("AOPD"))
+6 SET ACHSCTV=+$PIECE($GET(^ACHSAOVU(0)),U)
+7 SET ACHSCTPG=$GET(^ACHSZOCT("PIG"))
+8 SET ACHSCTPG=$GET(^ACHSPIG(0,0))
+9 ;ACHS*3.1*23
SET ACHSCTP2=$GET(^ACHSPG2(0,0))
+10 SET ACHSCCOR=$GET(^ACHSCORE("COUNT"))
+11 ;ACHS*3.1*13 6.14.2007 IHS/OIT/FCJ ADDED COUNTER FOR UFMS REC
SET ACHSCTUF=$GET(^ACHSUFMS("COUNT"))
+12 ;ACHS*3.1*13 6.14.2007 IHS/OIT/FCJ ADDED COUNTER FOR UFMS $
SET ACHSCTUA=$GET(^ACHSUFMS(0))
+13 SET ACHSCCOR("P")=$$AOP^ACHS(2,2)
+14 USE IO(0)
+15 ;
+16 WRITE !,"Transferring ",$PIECE(ACHSXD2,U,7)," CHS Data Records..."
+17 WRITE !,"From ",$PIECE($PIECE(IOPAR,":"),"(",2),!!
+18 SET DX=$X
SET DY=$Y
+19 SET ACHSCTVS=ACHSCTV+1
+20 ;
+21 ;adding new var TCOUNT for transaction count. 1/4/01 pmf
+22 ;F D Q:$E(X)="*"
+23 FOR TCOUNT=1:1
Begin DoDot:1
+24 USE IO
+25 READ X:300
+26 ;REACHED EOF MARK -GOOD FILE
IF $EXTRACT(X)="*"
QUIT
+27 READ ACHSX2:300
+28 ;I '($E(ACHSX2)) Q ;ACHS*3.1*13 IHS/OIT/FCJ COMMENTED OUT TO READ "U" TYPE REC
+29 DO T
+30 ;
SET X=+$PIECE($PIECE(X,"(",2),")")
+31 ;
+32 ;the next couple of lines is supposed to tell them when
+33 ;every 10 records have been transferred, with a little
+34 ;fancy video stuff. however, the value of X may not be
+35 ;what we need it to be, and the IOXY execution is not
+36 ;working at all, so I'm replacing it.
+37 ;keep these comments until the end of beta testing, just
+38 ;so we keep track of what's going on. 1/4/01 pmf
+39 ;I '(X#10) U IO(0) W X X IOXY
+40 IF TCOUNT#10=0
USE IO(0)
WRITE TCOUNT," "
End DoDot:1
IF $EXTRACT(X)="*"
QUIT
+41 ;
+42 ;REACHED END OF FILE WITH NO BAD RECORDS
+43 DO END^ACHSACO2
+44 QUIT
+45 ;
+46 ;
T ;
+1 ;S ACHSRTYP=+$E(ACHSX2) ;RECORD TYPE
+2 ;RECORD TYPE ACHS*3.1*13 IHS/OIT/FCJ Removed "+" TO READ "U" TYPE REC
SET ACHSRTYP=$EXTRACT(ACHSX2)
+3 ;COUNT OF RECORD TYPES
SET ACHSTOTL(ACHSRTYP)=ACHSTOTL(ACHSRTYP)+1
+4 ;FACILITY COUNT
IF '$DATA(ACHSZFAC(ACHSFCPT))
SET ACHSZFAC(ACHSFCPT)=0
+5 SET $PIECE(ACHSZFAC(ACHSFCPT),U)=$PIECE(ACHSZFAC(ACHSFCPT),U)+1
+6 ;
+7 ;
+8 ;FACILITY GENERATED DHR RECORD
IF ACHSRTYP=2
DO T2
+9 ;INCLUDES 638 DENTAL RECORD FOR NPIRS
+10 ; BEGINNING WITH '25'
+11 ;
+12 ;PATIENT RECORD. INCLUDES 3A, 3B
IF ACHSRTYP=3
DO T3
+13 ;AND 3C THIRD PARTY COVERAGE
+14 ;
+15 ;VENDOR RECORD. INCLUDES 4A AND 4B
IF ACHSRTYP=4
DO T4
+16 ;
+17 ;DOCUMENT (PURCHASE ORDER) RECORD
IF ACHSRTYP=5
DO T5
+18 ;INCLUDES 5A AND 5B
+19 ;
+20 ;PAYMENT RECORD FOR AREA OFFICE
IF ACHSRTYP=6
DO T6
+21 ;INCLUDES 6A AND 6B
+22 ;
+23 ;638 STATISTICAL RECORDS FOR NPIRS
IF ACHSRTYP=7
DO T7
+24 ;INCLUDES 7A AND 7B
+25 ;UFMS RECORD ;ACHS*3.1*13 IHS/OIT/FCJ Added for UFMS REC
IF ACHSRTYP="U"
DO TU
+26 ;
+27 ;ACHS*3.1*13 IHS/OIT/FCJ ADDED "U" TO NXT LINE
+28 ;F ACHSJ=2:1:7 S:ACHSTOTL(ACHSJ)>0 ACHSZFAC(ACHSFCPT,ACHSDRUN,ACHSJ)=ACHSTOTL(ACHSJ)
+29 FOR ACHSJ=2:1:7,"U"
IF ACHSTOTL(ACHSJ)>0
SET ACHSZFAC(ACHSFCPT,ACHSDRUN,ACHSJ)=ACHSTOTL(ACHSJ)
+30 QUIT
+31 ;
T2 ; FACILITY GENERATED DHR records for HAS and/or CORE.
+1 ; For HAS
+2 ; ALWAYS CREATE THE ACHSPCC GLOBAL FOR TRANSMISSION
Begin DoDot:1
+3 NEW ACHSSRTY
+4 ;IF SECOND CHAR IS "B" OR "C" THEN OKAY
+5 ;OTHERWISE SET NULL
+6 SET ACHSSRTY=$SELECT("BC"[$EXTRACT(ACHSX2,2):$EXTRACT(ACHSX2,2),1:"")
+7 ;I HAVE SEEN THE SECOND CHAR AS A "5" AND A "0"
+8 ;"20" ????? AND "25" DENTAL RECORDS
IF ACHSSRTY=""
SET ACHSHR1=ACHSX2
+9 ;
+10 IF ACHSSRTY="B"
SET ACHSHR2=ACHSX2
+11 ;
+12 IF ACHSSRTY="C"
Begin DoDot:2
+13 SET ACHSCT=ACHSCT+1
+14 SET ^ACHSPCC(ACHSFACD,ACHSCT)=$$CORE(1)
+15 SET ACHSCT=ACHSCT+1
+16 SET ^ACHSPCC(ACHSFACD,ACHSCT)=$$CORE(2)
End DoDot:2
+17 SET ^ACHSPCC("COUNT")=ACHSCT
End DoDot:1
+18 ;
+19 ; For CORE
+20 ;I ACHSCCOR("P")'="HAS" S ACHSCCOR=ACHSCCOR+1,^ACHSCORE(ACHSFACD,ACHSCCOR)=ACHSX2,^ACHSCORE("COUNT")=ACHSCCOR
+21 QUIT
+22 ;
T3 ;
+1 ;IF WE SHOULD PROCESS FI DATA AND THERE ARE FACILITIES EXPORTING FI DATA
+2 ;'PROCESS FI DATA' 'FACILITIES EXPORTING FI DATA'
+3 IF $$AOP^ACHS(2,3)'="Y"!('$DATA(^ACHSAOP(DUZ(2),20,ACHSFCPT)))
QUIT
+4 SET ACHSCTFI=ACHSCTFI+1
SET ^ACHSBCBS(ACHSCTFI)=ACHSX2
+5 QUIT
+6 ;
T4 ;
+1 ;CHECK TO SEE IF WE SHOULD PROCESS 3RD PARTY COVERAGE TO FI AND WHERE
+2 ;'PROCESS FI DATA' 'FACILITIES EXPORTING FI DATA'
+3 IF $$AOP^ACHS(2,3)'="Y"!('$DATA(^ACHSAOP(DUZ(2),20,ACHSFCPT)))
GOTO T4A
+4 SET ACHSCTFI=ACHSCTFI+1
SET ^ACHSBCBS(ACHSCTFI)=ACHSX2
T4A ;
+1 ;CHECK TO SEE IF WE SHOULD PROCESS AREA OFFICE DATA
+2 ;'PROCESS AREA OFFICE DATA'
+3 IF $$AOP^ACHS(2,4)'="Y"
QUIT
+4 SET ACHSCTV=ACHSCTV+1
SET ^ACHSAOVU(ACHSCTV)=ACHSX2
+5 QUIT
+6 ;
T5 ;'PROCESS FI DATA' 'FACILITIES EXPORTING FI DATA'
+1 IF $$AOP^ACHS(2,3)="Y"
IF $DATA(^ACHSAOP(DUZ(2),20,ACHSFCPT))
SET ACHSCTFI=ACHSCTFI+1
SET ^ACHSBCBS(ACHSCTFI)=ACHSX2
+2 ;IF 'SPECIAL REPORT VENDORS'
IF $DATA(^ACHSAOP(DUZ(2),21))
DO SVRSUB
+3 QUIT
+4 ;
T6 ;'PROCESS AREA OFFICE DATA'
+1 IF $$AOP^ACHS(2,4)'="Y"
QUIT
+2 SET ACHSCTPD=ACHSCTPD+1
SET ^ACHSAOPD(ACHSCTPD)=ACHSX2
+3 QUIT
+4 ;
T7 ; Statistical records.
+1 ;ACHS*3.1*23 ADDED TEST FOR NEW STAT RECORD.
+2 IF ACHSSTV="CRV003"
Begin DoDot:1
+3 SET ACHSCTP2=ACHSCTP2+1
+4 IF $EXTRACT(ACHSX2,1,2)="7A"
SET ACHSSTYP=$EXTRACT(ACHSX2,3,4)
+5 SET ^ACHSPG2(ACHSSTYP,ACHSFACD,ACHSCTP2)=ACHSX2
End DoDot:1
+6 IF '$TEST
Begin DoDot:1
+7 SET ACHSCTPG=ACHSCTPG+1
+8 IF $EXTRACT(ACHSX2,1,2)="7A"
SET ACHSSTYP=$EXTRACT(ACHSX2,3,4)
+9 SET ^ACHSPIG(ACHSSTYP,ACHSFACD,ACHSCTPG)=ACHSX2
End DoDot:1
+10 QUIT
TU ; UFMS Record ;ACHS*3.1*13 IHS/OIT/FCJ ADDED FOR PROCESSING UFMS RECORD
+1 IF $EXTRACT(ACHSX2,1,2)'="U2"
QUIT
+2 SET ACHSCTUF=ACHSCTUF+1
+3 SET ^ACHSUFMS(ACHSCTUF)=$EXTRACT(ACHSX2,2,161)
+4 SET ACHSCTUA=ACHSCTUA+$EXTRACT(ACHSX2,53,64)
+5 QUIT
+6 ;
SVRSUB ; Generate ^ACHSSVR global from 5A & 5B records.
+1 IF $EXTRACT(ACHSX2,1,2)="5A"
GOTO SVR5A
IF $EXTRACT(ACHSX2,1,2)="5B"
GOTO SVR5B
+2 QUIT
+3 ;
SVR5A ;
+1 KILL ACHSX3
+2 SET DIC="^AUTTVNDR("
SET DIC(0)="M"
SET D="C"
SET X=$EXTRACT(ACHSX2,22,33)
+3 IF $EXTRACT(X,11,12)=" "
SET X=$EXTRACT(X,1,10)
+4 DO ^DIC
+5 IF Y<1
QUIT
+6 IF '$DATA(^ACHSAOP(DUZ(2),21,"B",+Y))
QUIT
+7 SET ACHSX3=ACHSX2
+8 SET ACHSZFAC=$EXTRACT(ACHSX2,15,20)
+9 SET ACHSEIN=$EXTRACT(ACHSX2,22,33)
+10 IF $EXTRACT(ACHSEIN,11,12)=" "
SET ACHSEIN=$EXTRACT(ACHSEIN,1,10)
+11 SET ACHSCTFS=ACHSCTFS+1
+12 SET ^ACHSSVR(ACHSEIN,ACHSZFAC,ACHSCTFS)=ACHSX3
+13 QUIT
+14 ;
SVR5B ;
+1 IF '$DATA(ACHSX3)
QUIT
+2 SET ACHSX4=ACHSX2
+3 SET ^ACHSSVR(ACHSEIN,ACHSZFAC,ACHSCTFS)=ACHSX3_ACHSX4
+4 QUIT
+5 ;
REC(X) ;EP - Return the name of the export record, 1-8.
+1 ;CALLED BY ACHSACO2+9 AT END OF REPORT
+2 ;ALSO CALLED BY:
+3 ; ACHSTX3+4,ACHSTX4+4,ACHSTX5+4,ACHSTX6+4,ACHSTX7+35
+4 ; ACHSTX8+6
+5 IF '$GET(X)
QUIT ""
+6 ;ACHS*3.1*13 IHS/OIT/FCJ ADDED UFMS REC TO REC SUB
+7 QUIT $PIECE("NOT USED^DHR RECORDS FOR HAS/CORE^PATIENT RECORDS FOR AO/FI^VENDOR RECORDS FOR AO/FI^DOCUMENT RECORDS FOR AO/FI^PAYMENT RECORDS FOR AO^STATISTICAL RECORDS^UFMS RECORDS",U,X)
+8 ;
+9 ;BEGIN CORE MODIFICATIONS ADDITIONAL CODE
CORE(R) ;PROCESS A '2B' RECORD INTO THE 80-160 '2' PART TWO RECORD
+1 IF R=1
Begin DoDot:1
+2 SET ACHSEIN=$EXTRACT(ACHSX2,3,14)
+3 SET R=$EXTRACT(ACHSHR1,1,64)_$EXTRACT(ACHSEIN_$JUSTIFY("",15),1,15)_" "
End DoDot:1
+4 IF R=2
Begin DoDot:1
+5 ;FISCAL YEAR
SET ACHSF12=$EXTRACT(ACHSHR2,59,60)
+6 ;BEGIN DATE
SET ACHSF10=$EXTRACT(ACHSHR2,61,64)
+7 ;END DATE
SET ACHSF11=$EXTRACT(ACHSHR2,65,68)
+8 SET R=$JUSTIFY("",45)_ACHSF10_ACHSF11_ACHSF12_$JUSTIFY("",25)
+9 ;REQUIRED BY HAS
SET R=$EXTRACT(R,1,60)_$$REPEAT^XLFSTR("9",20)
End DoDot:1
+10 QUIT R
+11 ;END CORE MODIFICATIONS ADDITIONAL CODE
