ACHSTXA1 ; IHS/ITSC/PMF - EXPORT DATA - RECORD 2(DHR), SPECIFIC RE-EXPORTS ; [ 11/26/2003 8:04 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**7,14,16**;JUNE 11,2001
;ITSC/SET/JVK ACHS*3.1*7 - TEST FOR NO E-SIG
; This routine was created from ACHSTX2, for use with exporting
; specifically selected document transactions. If any change in logic
; is made to ACHSTX2, the change should also be made to this routine.
;ACHS*3.1*16 10/15/2009 IHS.OIT.FCJ FX FY 2 DIG YEAR PROBLEM
;
D LINES^ACHSFU
W @IOF,!,$$REPEAT^XLFSTR("*",80),!,$$C^XBFUNC("RE-EXPORT SELECTED CHS DATA"),!,$$REPEAT^XLFSTR("*"),!
S ACHSCHSS=""
D ^ACHSUF
K ACHSCHSS
D KILLGLBS^ACHSTX
S (J,ACHSDCR,ACHSEDT,ACHSBDT)=0,ACHSRR="",ACHSF638=$$PARM^ACHS(0,8)
F ACHS=2:1:7 S ACHSRTYP(ACHS)=0
W !?10,"FACILITY NAME: ",$$LOC^ACHS
S ACHSBDT=0,ACHSEDT=3990000
S2 ;
G ERR:ACHSEDT=0
S ACHSFDT=ACHSBDT
S ACHSAFAC=$P(^AUTTLOC(DUZ(2),0),U,10)
I $$PARM^ACHS(2,25)="Y" S X=$$PARM^ACHS(0,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(^TMP("ACHSTXAR",$J,ACHSBDT))
G CVTEND1:ACHSBDT<1!(ACHSBDT>ACHSEDT)
S ACHSLDAT=ACHSBDT
S ACHSDIEN=""
S4 ;
S ACHSDIEN=$O(^TMP("ACHSTXAR",$J,ACHSBDT,ACHSDIEN))
G S3:ACHSDIEN=""
G S4:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,0)) S ACHSDOCR=^(0)
G S4:$P(ACHSDOCR,U,3)=2
S ACHSTOS=$P(ACHSDOCR,U,4)
S ACHSTIEN=0
S5 ;
S ACHSTIEN=$O(^TMP("ACHSTXAR",$J,ACHSBDT,ACHSDIEN,ACHSTIEN))
G S4:ACHSTIEN<1
G S5:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0)) S ACHSTRNR=^(0)
S ACHSTY=$P(ACHSTRNR,U,2)
G S5:ACHSTY="ZA"!(ACHSTY="IP")
;ITSC/SET/JVK ACHS*3.1*7 10/30/2003
;ITSC/SET/JVK ACHS*3.1*7 11/26/2003 CMT OUT NXT 2
;S ACHSESIG=$P(ACHSDOCR,U,24)
;S ACHSADT=$P($G(^ACHSESIG(DUZ(2),0)),U,3)
;ITSC/SET/JVK END ACHS*3.1*7
S ACHSDEST=$P(ACHSDOCR,U,17),ACHSCTY=ACHSTY
;
S X=$P(ACHSTRNR,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(ACHSTRNR,U,5)
I ACHSF638="Y",$$PARM^ACHS(2,9)="Y" G S7
S:ACHSTY="P"&(ACHSDEST'="F") ^ACHSTXPD(ACHSDIEN,ACHSTIEN)=""
S ACHSPROV=$P(ACHSDOCR,U,8)
S:'$D(^ACHSTXVN(ACHSPROV)) ^ACHSTXVN(ACHSPROV)=ACHSDEST
S7 ;
;ITSC/SET/JVK ACHS*3.1*7 CMT OUT NXT 1
;I ACHSDEST="F"!(ACHSTY'="P") G S8
I $$PARM^ACHS(2,9)'="Y" G S7A
S ^ACHSTXPG(ACHSTOS,ACHSDIEN,ACHSTIEN)=""
S7A ;
I ACHSF638'="Y" G S8
S:'$P(ACHSDOCR,U,3) ^ACHSTXPG(ACHSTOS,ACHSDIEN,ACHSTIEN)=""
;ACHS*3.1*14 IHS/OIT/FCJ Commented out next line because some 638 sites send FI data
;G S5
S8 ;
G S5:ACHSTY="P"
;ITSC/SET/JVK ACHS*3.1*7 11/26/2003 CMT NXT 1
;G S5:(ACHSESIG="")&(ACHSBDT>ACHSADT)
I ACHSF638="Y",$$PARM^ACHS(2,9)="Y" G S5
S ^ACHSTXOB(ACHSDIEN,ACHSTIEN)=""
;
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:"")
;ACHS*3.1*16 10/15/2009 IHS.OIT.FCJ ADDED CORRECT FY
;S ACHSDOCN=0_X1_ACHSXLOC_$P(ACHSDOCR,U)
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,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 = ",!!
W $J(ACHSRCT,8)
D BC^ACHSTX2
G S5
;
ERR ;
W !!,*7,*7,"DCR REGISTER ERROR YOU MUST CLOSE YOUR REGISTERS FIRST"
D ^%ZISC,KILL^ACHSTX8
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,ACHSSCC,ACHSTRNR,ACHSTY,X1,ACHSXLOC
G ^ACHSTX3
;
ACHSTXA1 ; IHS/ITSC/PMF - EXPORT DATA - RECORD 2(DHR), SPECIFIC RE-EXPORTS ; [ 11/26/2003 8:04 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**7,14,16**;JUNE 11,2001
+2 ;ITSC/SET/JVK ACHS*3.1*7 - TEST FOR NO E-SIG
+3 ; This routine was created from ACHSTX2, for use with exporting
+4 ; specifically selected document transactions. If any change in logic
+5 ; is made to ACHSTX2, the change should also be made to this routine.
+6 ;ACHS*3.1*16 10/15/2009 IHS.OIT.FCJ FX FY 2 DIG YEAR PROBLEM
+7 ;
+8 DO LINES^ACHSFU
+9 WRITE @IOF,!,$$REPEAT^XLFSTR("*",80),!,$$C^XBFUNC("RE-EXPORT SELECTED CHS DATA"),!,$$REPEAT^XLFSTR("*"),!
+10 SET ACHSCHSS=""
+11 DO ^ACHSUF
+12 KILL ACHSCHSS
+13 DO KILLGLBS^ACHSTX
+14 SET (J,ACHSDCR,ACHSEDT,ACHSBDT)=0
SET ACHSRR=""
SET ACHSF638=$$PARM^ACHS(0,8)
+15 FOR ACHS=2:1:7
SET ACHSRTYP(ACHS)=0
+16 WRITE !?10,"FACILITY NAME: ",$$LOC^ACHS
+17 SET ACHSBDT=0
SET ACHSEDT=3990000
S2 ;
+1 IF ACHSEDT=0
GOTO ERR
+2 SET ACHSFDT=ACHSBDT
+3 SET ACHSAFAC=$PIECE(^AUTTLOC(DUZ(2),0),U,10)
+4 IF $$PARM^ACHS(2,25)="Y"
SET X=$$PARM^ACHS(0,12)
IF +X<1
GOTO AFACERR
SET ACHSAFAC=$PIECE(^AUTTLOC(X,0),U,10)
+5 IF +ACHSAFAC<1
GOTO AFACERR
+6 IF $$PARM^ACHS(2,9)="Y"
FOR ACHS="252F","254V"
SET ACHS(ACHS)=$ORDER(^ACHS(3,DUZ(2),1,"B",ACHS,0))
+7 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(^TMP("ACHSTXAR",$JOB,ACHSBDT))
+2 IF ACHSBDT<1!(ACHSBDT>ACHSEDT)
GOTO CVTEND1
+3 SET ACHSLDAT=ACHSBDT
+4 SET ACHSDIEN=""
S4 ;
+1 SET ACHSDIEN=$ORDER(^TMP("ACHSTXAR",$JOB,ACHSBDT,ACHSDIEN))
+2 IF ACHSDIEN=""
GOTO S3
+3 IF '$DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,0))
GOTO S4
SET ACHSDOCR=^(0)
+4 IF $PIECE(ACHSDOCR,U,3)=2
GOTO S4
+5 SET ACHSTOS=$PIECE(ACHSDOCR,U,4)
+6 SET ACHSTIEN=0
S5 ;
+1 SET ACHSTIEN=$ORDER(^TMP("ACHSTXAR",$JOB,ACHSBDT,ACHSDIEN,ACHSTIEN))
+2 IF ACHSTIEN<1
GOTO S4
+3 IF '$DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0))
GOTO S5
SET ACHSTRNR=^(0)
+4 SET ACHSTY=$PIECE(ACHSTRNR,U,2)
+5 IF ACHSTY="ZA"!(ACHSTY="IP")
GOTO S5
+6 ;ITSC/SET/JVK ACHS*3.1*7 10/30/2003
+7 ;ITSC/SET/JVK ACHS*3.1*7 11/26/2003 CMT OUT NXT 2
+8 ;S ACHSESIG=$P(ACHSDOCR,U,24)
+9 ;S ACHSADT=$P($G(^ACHSESIG(DUZ(2),0)),U,3)
+10 ;ITSC/SET/JVK END ACHS*3.1*7
+11 SET ACHSDEST=$PIECE(ACHSDOCR,U,17)
SET ACHSCTY=ACHSTY
+12 ;
+13 SET X=$PIECE(ACHSTRNR,U,4)
SET X=$PIECE(X,".",1)_$EXTRACT($PIECE(X,".",2)_"00",1,2)
SET ACHSIPA=$EXTRACT(X+1000000000000,2,13)
+14 IF ACHSCTY="C"
SET ACHSCTY=$PIECE(ACHSTRNR,U,5)
+15 IF ACHSF638="Y"
IF $$PARM^ACHS(2,9)="Y"
GOTO S7
+16 IF ACHSTY="P"&(ACHSDEST'="F")
SET ^ACHSTXPD(ACHSDIEN,ACHSTIEN)=""
+17 SET ACHSPROV=$PIECE(ACHSDOCR,U,8)
+18 IF '$DATA(^ACHSTXVN(ACHSPROV))
SET ^ACHSTXVN(ACHSPROV)=ACHSDEST
S7 ;
+1 ;ITSC/SET/JVK ACHS*3.1*7 CMT OUT NXT 1
+2 ;I ACHSDEST="F"!(ACHSTY'="P") G S8
+3 IF $$PARM^ACHS(2,9)'="Y"
GOTO S7A
+4 SET ^ACHSTXPG(ACHSTOS,ACHSDIEN,ACHSTIEN)=""
S7A ;
+1 IF ACHSF638'="Y"
GOTO S8
+2 IF '$PIECE(ACHSDOCR,U,3)
SET ^ACHSTXPG(ACHSTOS,ACHSDIEN,ACHSTIEN)=""
+3 ;ACHS*3.1*14 IHS/OIT/FCJ Commented out next line because some 638 sites send FI data
+4 ;G S5
S8 ;
+1 IF ACHSTY="P"
GOTO S5
+2 ;ITSC/SET/JVK ACHS*3.1*7 11/26/2003 CMT NXT 1
+3 ;G S5:(ACHSESIG="")&(ACHSBDT>ACHSADT)
+4 IF ACHSF638="Y"
IF $$PARM^ACHS(2,9)="Y"
GOTO S5
+5 SET ^ACHSTXOB(ACHSDIEN,ACHSTIEN)=""
+6 ;
+7 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
+8 ;
+9 SET (ACHSX,X1)=$PIECE(ACHSDOCR,U,14)
+10 DO FYCVT^ACHSFU
+11 SET ACHSXLOC=ACHSFC
+12 IF ACHSY<1987
SET ACHSXLOC="0"_$EXTRACT(ACHSFC,2,3)
+13 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:"")
+14 ;ACHS*3.1*16 10/15/2009 IHS.OIT.FCJ ADDED CORRECT FY
+15 ;S ACHSDOCN=0_X1_ACHSXLOC_$P(ACHSDOCR,U)
+16 SET ACHSDOCN=$EXTRACT($PIECE(ACHSDOCR,U,27),3,4)_ACHSXLOC_$PIECE(ACHSDOCR,U)
+17 IF '$DATA(^ACHSTXVN(ACHSPROV))
SET ^ACHSTXVN(ACHSPROV)=ACHSDEST
+18 ;
+19 IF ACHSCDE=""
GOTO ERROR^ACHSTX
+20 DO CANOBJ^ACHSTX8
+21 SET ACHSFED=$SELECT($PIECE(^AUTTVNDR(ACHSPROV,11),U,10)=2:2,1:1)
+22 SET ACHSRCT=ACHSRCT+1
SET ACHSRTYP(2)=ACHSRTYP(2)+1
+23 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)
+24 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
+25 IF ACHSRCT=1
SET ACHSFDT=ACHSBDT
WRITE !!,"NUMBER OF RECORDS PROCESSED = ",!!
+26 WRITE $JUSTIFY(ACHSRCT,8)
+27 DO BC^ACHSTX2
+28 GOTO S5
+29 ;
ERR ;
+1 WRITE !!,*7,*7,"DCR REGISTER ERROR YOU MUST CLOSE YOUR REGISTERS FIRST"
+2 DO ^%ZISC
DO KILL^ACHSTX8
+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,ACHSSCC,ACHSTRNR,ACHSTY,X1,ACHSXLOC
+4 GOTO ^ACHSTX3
+5 ;
