ACHSTX2 ; IHS/ITSC/PMF - EXPORT DATA (3/9) - RECORD 2(DHR), SET GLOBALS FOR OTHER RECORD TYPES ;JUL 10, 2008
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**7,13,14,15,16,22**;JUN 11,2001;Build 43
;ITSC/SET/JVK 10-29-03 ACHS*3.1*7 - TEST FOR E-SIG ON EXPORT
;ACHS*3.1*13 6.13.2007 IHS/OIT/FCJ ADDED REC CNT FOR UFMS and also create UFMS record for live testing
;ACHS*3.1*14 8.31.2007 IHS/OIT/FCJ Fixed Tribal Stat records: Only Pay Documents and only if parameter is set
;
; This routine was used to create routine ACHSTXA1, which is used in
; creation of DHR records for specifically selected document
; transactions. If any change is made to the logic in this routine,
; the same logic change should be made to ACHSTXA1.
;
D LINES^ACHSFU
W @IOF,!,ACHS("*"),!?30,"EXPORT CHS DATA",!,ACHS("*"),!
S ACHSCHSS=""
D ^ACHSUF
K ACHSCHSS
D KILLGLBS^ACHSTX
S (J,ACHSDCR,ACHSEDT,ACHSBDT)=0,ACHSRR="",ACHSF638=$P(^ACHSF(DUZ(2),0),U,8)
;F ACHS=2:1:7 S ACHSRTYP(ACHS)=0
F ACHS=2:1:8 S ACHSRTYP(ACHS)=0 ;ACHS*3.1*13 6.13.2007 IHS/OIT/FCJ ADDED RECORD COUNT 8 FOR UFMS
I '$D(^ACHSTXST(DUZ(2))) S DA=9999998-DT G S1
F I=1:1 S J=$O(^ACHSTXST(DUZ(2),1,J)) Q:+J<1 S P=J
S ACHSBDT=$P(^ACHSTXST(DUZ(2),1,P,0),U,3),N=9999998-DT,DA=N
S DA=DA-1
S1 ;
S DA=$O(^ACHS(9,DUZ(2),"FY",ACHSCFY,"AR",DA))
G S2:DA<1
S11 ;
S ACHSDCR=$O(^ACHS(9,DUZ(2),"FY",ACHSCFY,"AR",DA,ACHSDCR))
G S1:ACHSDCR<1,S11:'$D(^ACHS(9,DUZ(2),"FY",ACHSCFY,"W",ACHSDCR,0)) I ACHSEDT'>$P(^(0),U,2) S ACHSEDT=$P(^(0),U,2)
G S11
;
S2 ;EP - For export Re-Generation.
G ERR:ACHSEDT=0
;
;ACHS*3.1*15 IHS.OIT.FCJ ADDED ACHSFDTT TO NXT LINE
S ACHSFDT=ACHSBDT,ACHSLDAT=ACHSEDT,ACHSAFAC=$P(^AUTTLOC(DUZ(2),0),U,10),ACHSFDTT=""
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 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))
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
;ITSC/SET/JVK ACHS*3.1*7 11/26/03 CMT OUT NXT TWO
;S ACHSESIG=$P($G(^ACHSF(DUZ(2),"D",P,0)),U,24)
;S ACHSADT=$P($G(^ACHSESIG(DUZ(2),0)),U,3)
;ITSC/SET/JVK END ACHS*3.1*7
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),"")
S ACHSPROV=$P(^ACHSF(DUZ(2),"D",P,0),U,8)
I ACHSF638="Y",$$PARM^ACHS(2,9)="Y" G S7
S:ACHSTY="P"&(ACHSDEST'="F") ^ACHSTXPD(P,DA)=""
S:'$D(^ACHSTXVN(ACHSPROV)) ^ACHSTXVN(ACHSPROV)=ACHSDEST
S7 ;
;ITSC/SET/JVK NOTE THIS LINE TO SEND REGARDLESS OF PAYMENT DESTINATION
;ONLY FI RECORDS IN RECORD TYPE 5
;I ACHSTY'="P" G S8
;ACHS*3.1*14 8.31.2007 IHS/OIT/FCJ changed nxt section for tribal stat data, commented out 6 lines added 1
;I ACHSDEST="F"!(ACHSTY'="P") G S8
;I $$PARM^ACHS(2,9)'="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
;ACHS*3.1*15 IHS.OIT.FCJ ADDED ACHSFDTT TO NXT LINE
I ACHSTY="P",$$PARM^ACHS(2,9)="Y",ACHSF638="Y",$P(ACHSDOCR,U,3)'=2 S ^ACHSTXPG(ACHSTOS,P,DA)="" S:ACHSFDTT="" ACHSFDTT=ACHSBDT
S8 ;
G S6:ACHSTY="P"
;ITSC/SET/JVK ACHS*3.1*7 11/26/03 CMT OUT NXT 1
;G S6:(ACHSESIG="")&(ACHSBDT>ACHSADT)
;ACHS*3.1*14 8.31.2007 IHS/OIT/FCJ CMT OUT 3 LINES ADDED 2
;I ACHSF638="Y",$$PARM^ACHS(2,9)'="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
D AF
G:ACHSF638="Y" S6 ;ACHS*3.1*14T 9.31.2007 IHS/OIT/FCJ Tribal sites do not need to create DHR records
S (ACHSX,X1)=$P(ACHSDOCR,U,14)
D FYCVT^ACHSFU
S ACHSXLOC=ACHSFC
S:ACHSY<1987 ACHSXLOC="0"_$E(ACHSFC,2,3)
;Y2000 The following line is OK ... YY is Y2K correct in CHS
;ACHS*3.1*16 10/15/2009 IHS.OIT.FCJ SPLIT NEXT LINE AND ADDED CORRECT FY
;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)
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:"")
S ACHSDOCN=$E($P(ACHSDOCR,U,27),3,4)_ACHSXLOC_$P(ACHSDOCR,U)
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 = ",!!
S ACHSERR=0 D S1^ACHSTXFT I ACHSERR G ERROR^ACHSTX ;ACHS*3.1*13 6.13.2007 IHS/OIT/FCJ Used for testing UFMS data
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
;
AF ;Area - FI records set globals ;ACHS*3.1*14 8.31.2007 IHS/OIT/FCJ ADDED SECTION
S:ACHSTY="P"&(ACHSDEST'="F")&($$PARM^ACHS(2,12)="Y") ^ACHSTXPD(P,DA)=""
;I $$PARM^ACHS(2,11)="Y" S ^ACHSTXOB(P,DA)=""
I $$PARM^ACHS(2,11)="Y",ACHSDEST="F" S ^ACHSTXOB(P,DA)="" ;ACHS*3.1*22 IHS/OIT/FCJ "I" TYPE DOC WERE BEING SENT TO THE FI
I ($$PARM^ACHS(2,11)="Y")!($$PARM^ACHS(2,12)="Y") 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
.S:'$D(^ACHSTXVN(ACHSPROV)) ^ACHSTXVN(ACHSPROV)=ACHSDEST
Q
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
;
ACHSTX2 ; IHS/ITSC/PMF - EXPORT DATA (3/9) - RECORD 2(DHR), SET GLOBALS FOR OTHER RECORD TYPES ;JUL 10, 2008
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**7,13,14,15,16,22**;JUN 11,2001;Build 43
+2 ;ITSC/SET/JVK 10-29-03 ACHS*3.1*7 - TEST FOR E-SIG ON EXPORT
+3 ;ACHS*3.1*13 6.13.2007 IHS/OIT/FCJ ADDED REC CNT FOR UFMS and also create UFMS record for live testing
+4 ;ACHS*3.1*14 8.31.2007 IHS/OIT/FCJ Fixed Tribal Stat records: Only Pay Documents and only if parameter is set
+5 ;
+6 ; This routine was used to create routine ACHSTXA1, which is used in
+7 ; creation of DHR records for specifically selected document
+8 ; transactions. If any change is made to the logic in this routine,
+9 ; the same logic change should be made to ACHSTXA1.
+10 ;
+11 DO LINES^ACHSFU
+12 WRITE @IOF,!,ACHS("*"),!?30,"EXPORT CHS DATA",!,ACHS("*"),!
+13 SET ACHSCHSS=""
+14 DO ^ACHSUF
+15 KILL ACHSCHSS
+16 DO KILLGLBS^ACHSTX
+17 SET (J,ACHSDCR,ACHSEDT,ACHSBDT)=0
SET ACHSRR=""
SET ACHSF638=$PIECE(^ACHSF(DUZ(2),0),U,8)
+18 ;F ACHS=2:1:7 S ACHSRTYP(ACHS)=0
+19 ;ACHS*3.1*13 6.13.2007 IHS/OIT/FCJ ADDED RECORD COUNT 8 FOR UFMS
FOR ACHS=2:1:8
SET ACHSRTYP(ACHS)=0
+20 IF '$DATA(^ACHSTXST(DUZ(2)))
SET DA=9999998-DT
GOTO S1
+21 FOR I=1:1
SET J=$ORDER(^ACHSTXST(DUZ(2),1,J))
IF +J<1
QUIT
SET P=J
+22 SET ACHSBDT=$PIECE(^ACHSTXST(DUZ(2),1,P,0),U,3)
SET N=9999998-DT
SET DA=N
+23 SET DA=DA-1
S1 ;
+1 SET DA=$ORDER(^ACHS(9,DUZ(2),"FY",ACHSCFY,"AR",DA))
+2 IF DA<1
GOTO S2
S11 ;
+1 SET ACHSDCR=$ORDER(^ACHS(9,DUZ(2),"FY",ACHSCFY,"AR",DA,ACHSDCR))
+2 IF ACHSDCR<1
GOTO S1
IF '$DATA(^ACHS(9,DUZ(2),"FY",ACHSCFY,"W",ACHSDCR,0))
GOTO S11
IF ACHSEDT'>$PIECE(^(0),U,2)
SET ACHSEDT=$PIECE(^(0),U,2)
+3 GOTO S11
+4 ;
S2 ;EP - For export Re-Generation.
+1 IF ACHSEDT=0
GOTO ERR
+2 ;
+3 ;ACHS*3.1*15 IHS.OIT.FCJ ADDED ACHSFDTT TO NXT LINE
+4 SET ACHSFDT=ACHSBDT
SET ACHSLDAT=ACHSEDT
SET ACHSAFAC=$PIECE(^AUTTLOC(DUZ(2),0),U,10)
SET ACHSFDTT=""
+5 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)
+6 IF +ACHSAFAC<1
GOTO AFACERR
+7 IF $$PARM^ACHS(2,9)="Y"
FOR ACHS="252F","254V"
SET ACHS(ACHS)=$ORDER(^ACHS(3,DUZ(2),1,"B",ACHS,0))
+8 IF ACHSF638="Y"
IF $$PARM^ACHS(2,9)="Y"
FOR ACHS="252G","252R","254D","254L","254M"
SET ACHS(ACHS)=$ORDER(^ACHS(3,DUZ(2),1,"B",ACHS,0))
S3 ;
+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 ;
+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 ;ITSC/SET/JVK ACHS*3.1*7 11/26/03 CMT OUT NXT TWO
+5 ;S ACHSESIG=$P($G(^ACHSF(DUZ(2),"D",P,0)),U,24)
+6 ;S ACHSADT=$P($G(^ACHSESIG(DUZ(2),0)),U,3)
+7 ;ITSC/SET/JVK END ACHS*3.1*7
+8 SET ACHSDEST=$PIECE($GET(^ACHSF(DUZ(2),"D",P,0)),U,17)
SET ACHSCTY=ACHSTY
+9 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)
+10 IF '$DATA(^ACHSF(DUZ(2),"D",P,0))
GOTO S6
SET ACHSDOCR=^(0)
SET ACHSTOS=$PIECE(ACHSDOCR,U,4)
+11 SET ACHSDR3=$GET(^ACHSF(DUZ(2),"D",P,3),"")
+12 SET ACHSPROV=$PIECE(^ACHSF(DUZ(2),"D",P,0),U,8)
+13 IF ACHSF638="Y"
IF $$PARM^ACHS(2,9)="Y"
GOTO S7
+14 IF ACHSTY="P"&(ACHSDEST'="F")
SET ^ACHSTXPD(P,DA)=""
+15 IF '$DATA(^ACHSTXVN(ACHSPROV))
SET ^ACHSTXVN(ACHSPROV)=ACHSDEST
S7 ;
+1 ;ITSC/SET/JVK NOTE THIS LINE TO SEND REGARDLESS OF PAYMENT DESTINATION
+2 ;ONLY FI RECORDS IN RECORD TYPE 5
+3 ;I ACHSTY'="P" G S8
+4 ;ACHS*3.1*14 8.31.2007 IHS/OIT/FCJ changed nxt section for tribal stat data, commented out 6 lines added 1
+5 ;I ACHSDEST="F"!(ACHSTY'="P") G S8
+6 ;I $$PARM^ACHS(2,9)'="Y" G S7A
+7 ;S ^ACHSTXPG(ACHSTOS,P,DA)=""
S7A ;
+1 ;I ACHSF638'="Y" G S8
+2 ;S:'$P(ACHSDOCR,U,3) ^ACHSTXPG(ACHSTOS,P,DA)=""
+3 ;G S6
+4 ;ACHS*3.1*15 IHS.OIT.FCJ ADDED ACHSFDTT TO NXT LINE
+5 IF ACHSTY="P"
IF $$PARM^ACHS(2,9)="Y"
IF ACHSF638="Y"
IF $PIECE(ACHSDOCR,U,3)'=2
SET ^ACHSTXPG(ACHSTOS,P,DA)=""
IF ACHSFDTT=""
SET ACHSFDTT=ACHSBDT
S8 ;
+1 IF ACHSTY="P"
GOTO S6
+2 ;ITSC/SET/JVK ACHS*3.1*7 11/26/03 CMT OUT NXT 1
+3 ;G S6:(ACHSESIG="")&(ACHSBDT>ACHSADT)
+4 ;ACHS*3.1*14 8.31.2007 IHS/OIT/FCJ CMT OUT 3 LINES ADDED 2
+5 ;I ACHSF638="Y",$$PARM^ACHS(2,9)'="Y" G S6
+6 ;S ^ACHSTXOB(P,DA)=""
+7 ;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
+8 DO AF
+9 ;ACHS*3.1*14T 9.31.2007 IHS/OIT/FCJ Tribal sites do not need to create DHR records
IF ACHSF638="Y"
GOTO S6
+10 SET (ACHSX,X1)=$PIECE(ACHSDOCR,U,14)
+11 DO FYCVT^ACHSFU
+12 SET ACHSXLOC=ACHSFC
+13 IF ACHSY<1987
SET ACHSXLOC="0"_$EXTRACT(ACHSFC,2,3)
+14 ;Y2000 The following line is OK ... YY is Y2K correct in CHS
+15 ;ACHS*3.1*16 10/15/2009 IHS.OIT.FCJ SPLIT NEXT LINE AND ADDED CORRECT FY
+16 ;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)
+17 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:"")
+18 SET ACHSDOCN=$EXTRACT($PIECE(ACHSDOCR,U,27),3,4)_ACHSXLOC_$PIECE(ACHSDOCR,U)
+19 IF '$DATA(^ACHSTXVN(ACHSPROV))
SET ^ACHSTXVN(ACHSPROV)=ACHSDEST
+20 IF ACHSCDE=""
GOTO ERROR^ACHSTX
+21 DO CANOBJ^ACHSTX8
+22 SET ACHSFED=$SELECT($PIECE(^AUTTVNDR(ACHSPROV,11),U,10)=2:2,1:1)
+23 ;RECORD COUNT
SET ACHSRCT=ACHSRCT+1
+24 SET ACHSRTYP(2)=ACHSRTYP(2)+1
+25 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)
+26 ;
+27 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
+28 IF ACHSRCT=1
SET ACHSFDT=ACHSBDT
WRITE !!,"NUMBER OF RECORDS PROCESSED = ",!!
+29 ;ACHS*3.1*13 6.13.2007 IHS/OIT/FCJ Used for testing UFMS data
SET ACHSERR=0
DO S1^ACHSTXFT
IF ACHSERR
GOTO ERROR^ACHSTX
+30 IF ACHSRCT#25=0
WRITE $JUSTIFY(ACHSRCT,8)
+31 DO BC
+32 GOTO S6
+33 ;
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 ;
AF ;Area - FI records set globals ;ACHS*3.1*14 8.31.2007 IHS/OIT/FCJ ADDED SECTION
+1 IF ACHSTY="P"&(ACHSDEST'="F")&($$PARM^ACHS(2,12)="Y")
SET ^ACHSTXPD(P,DA)=""
+2 ;I $$PARM^ACHS(2,11)="Y" S ^ACHSTXOB(P,DA)=""
+3 ;ACHS*3.1*22 IHS/OIT/FCJ "I" TYPE DOC WERE BEING SENT TO THE FI
IF $$PARM^ACHS(2,11)="Y"
IF ACHSDEST="F"
SET ^ACHSTXOB(P,DA)=""
+4 IF ($$PARM^ACHS(2,11)="Y")!($$PARM^ACHS(2,12)="Y")
Begin DoDot:1
+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 IF '$DATA(^ACHSTXVN(ACHSPROV))
SET ^ACHSTXVN(ACHSPROV)=ACHSDEST
End DoDot:1
+7 QUIT
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 ;
