ACHSEXUT ; IHS/ITSC/PMF - GENERIC PRE EXPORT (SPLIT-OUT) PROCESSING PROGRAM ; [ 12/06/2002 10:36 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5,22**;JUN 11, 2001;Build 43
;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Clarify error message. Remove ref to non-package global.
;ACHS*3.1*22 OS test when writing to the directory
;
FILESEL ;EP
;
I $D(DTOUT) S ACHSOUT=1 Q
D PARMCHK^ACHSTUT2
I $D(ACHSJFLG) Q
A9 ;S X="EXPORT PROCESSING OF "_ACHSTXNM_" DATA TO "_ACHSCCTR
;W !,?80-$L(X)/2,X,!
;F ACHSI=1:1:79 W "*"
S ACHSXXX=""
S:$D(ACHSHBCL) ACHSXXX=ACHSHBCL
S ACHSXX="ibm"
S:$L(ACHSHDNM>1) ACHSXX=ACHSHDNM_ACHSXXX
S ACHSZFN=ACHSUXFP_ACHSXX,ACHSZOPT=1,ACHSFNLN=$L(ACHSZFN)
K ACHSJFLG
D ARCHLIST^ACHSARCH
Q:$D(DUOUT)!$D(DTOUT)
I $D(ACHSJFLG) Q
S ACHSDTJL=$E(DT,2,3)_$$JDT^ACHS(DT,1)
I '$D(ACHSFILE("N",ACHSDTJL)) S X=$C(97) G NAMEGEN
FILEDSP ;
W @IOF
A10 ;
W !!,"The following data has been processed TODAY: ",!
A20 ;
S (ACHSR,ACHSRR,ACHSSEQ)=0
W !,"SEQ # ","# RCDS EXPORT - DATE FILE NAME - SFX OK-TX? COLOR",!!
FILEDSPA ;
S ACHSR=$O(ACHSFILE("N",ACHSDTJL,ACHSR))
G DSPEND:ACHSR=""
FILEDSPB ;
S ACHSRR=$O(ACHSFILE("N",ACHSDTJL,ACHSR,ACHSRR))
G FILEDSPA:ACHSRR=""
S ACHSFNAM=$P(ACHSFILE(ACHSRR),U,2),ACHSXPT=0,ACHSXPT=$O(^AFSTXLOG(DUZ(2),1,"B",ACHSFNAM,ACHSXPT))
;I +ACHSXPT<1 S ACHSEMSG="ERROR IN TX/EXPORT DATA STRUCTURE -- NOTIFY SUPERVISOR ",ACHSJFLG=1 G JCANCEL;IHS/SET/GTH ACHS*3.1*5 12/06/2002
I +ACHSXPT<1 W !,"No entries for '",ACHSFNAM,"' for ",$$LOC^ACHS," in IHS DATA TRANSMISSION LOG file" G FILEDSPB ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
S ACHSZ=ACHSFILE(ACHSRR),ACHSTXST="N",$P(ACHSFILE(ACHSRR),U,3)="N"
;S:+ACHSXPT>0 ACHSTXST=$P(^AFSTXLOG(DUZ(2),1,ACHSXPT,0),U,4),$P(ACHSFILE(ACHSRR),U,3)=ACHSTXST;IHS/SET/GTH ACHS*3.1*5 12/06/2002
S:+ACHSXPT>0 ACHSTXST=$$GET1^DIQ(9002320.52,ACHSXPT_","_DUZ(2)_",",3,"I"),$P(ACHSFILE(ACHSRR),U,3)=ACHSTXST ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
;S ACHSHCLR=$P(^AFSTXLOG(DUZ(2),1,ACHSXPT,0),U,5);IHS/SET/GTH ACHS*3.1*5 12/06/2002
;S ACHSHCLR=$S(ACHSHCLR="R":"RED",ACHSHCLR="B":"BLUE",1:"");IHS/SET/GTH ACHS*3.1*5 12/06/2002
S ACHSHCLR=$$GET1^DIQ(9002320.52,ACHSXPT_","_DUZ(2)_",",3.11) ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
S X=$P($P(ACHSFILE(ACHSRR),".",2),U,1)
S Y=$$GDT^ACHS(X)
S X=$P(ACHSFILE(ACHSRR),U,1),Z=X/81,X=$J(Z,0,0)
S ACHSSEQ=ACHSSEQ+1
W $J(ACHSSEQ,3),?6,$J(X,6),?17,Y
S Z=$P(ACHSFILE(ACHSRR),U,2),ACHSZZ1=$P($P(ACHSZ,U,2),".",1),X=$P(Z,".",1)
W ?33,$E(X,1,ACHSFNLN),?45,$E(X,ACHSFNLN+1,ACHSFNLN+1),?51,ACHSTXST,?57,ACHSHCLR,!
G FILEDSPB
;
DSPEND ;
S Y=$$DIR^XBDIR("Y","Do you want to Continue","Y")
I Y=0 S %="M9",ACHSEMSG=$P($T(@%^ACHSTCK1),";;",2),ACHSJFLG=1 G JCANCEL
S X=$E(ACHSZZ1,$L(ACHSZZ1),$L(ACHSZZ1)),Y=$A(X),X=$C(Y+1)
NAMEGEN ;
;S ACHSEXFN=ACHSZDIR_"/"_ACHSUXFP_ACHSXX_X_"."_ACHSDTJL,ACHSEXFS=ACHSUXFP_ACHSXX_X_"."_ACHSDTJL ;ACHS*3.1*22
S ACHSEXFN=ACHSZDIR_$S($$OS^ACHS=2:"\",1:"/")_ACHSUXFP_ACHSXX_X_"."_ACHSDTJL ;ACHS*3.1*22 IHS.OIT.FCJ
S ACHSEXFS=ACHSUXFP_ACHSXX_X_"."_ACHSDTJL ;ACHS*3.1*22
Q
;
JCANCEL ;
U IO(0)
W *7,!!,ACHSEMSG,!
I $$DIR^XBDIR("E","Press RETURN...")
S ACHSJFLG=1
Q
;
ACHSEXUT ; IHS/ITSC/PMF - GENERIC PRE EXPORT (SPLIT-OUT) PROCESSING PROGRAM ; [ 12/06/2002 10:36 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5,22**;JUN 11, 2001;Build 43
+2 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Clarify error message. Remove ref to non-package global.
+3 ;ACHS*3.1*22 OS test when writing to the directory
+4 ;
FILESEL ;EP
+1 ;
+2 IF $DATA(DTOUT)
SET ACHSOUT=1
QUIT
+3 DO PARMCHK^ACHSTUT2
+4 IF $DATA(ACHSJFLG)
QUIT
A9 ;S X="EXPORT PROCESSING OF "_ACHSTXNM_" DATA TO "_ACHSCCTR
+1 ;W !,?80-$L(X)/2,X,!
+2 ;F ACHSI=1:1:79 W "*"
+3 SET ACHSXXX=""
+4 IF $DATA(ACHSHBCL)
SET ACHSXXX=ACHSHBCL
+5 SET ACHSXX="ibm"
+6 IF $LENGTH(ACHSHDNM>1)
SET ACHSXX=ACHSHDNM_ACHSXXX
+7 SET ACHSZFN=ACHSUXFP_ACHSXX
SET ACHSZOPT=1
SET ACHSFNLN=$LENGTH(ACHSZFN)
+8 KILL ACHSJFLG
+9 DO ARCHLIST^ACHSARCH
+10 IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+11 IF $DATA(ACHSJFLG)
QUIT
+12 SET ACHSDTJL=$EXTRACT(DT,2,3)_$$JDT^ACHS(DT,1)
+13 IF '$DATA(ACHSFILE("N",ACHSDTJL))
SET X=$CHAR(97)
GOTO NAMEGEN
FILEDSP ;
+1 WRITE @IOF
A10 ;
+1 WRITE !!,"The following data has been processed TODAY: ",!
A20 ;
+1 SET (ACHSR,ACHSRR,ACHSSEQ)=0
+2 WRITE !,"SEQ # ","# RCDS EXPORT - DATE FILE NAME - SFX OK-TX? COLOR",!!
FILEDSPA ;
+1 SET ACHSR=$ORDER(ACHSFILE("N",ACHSDTJL,ACHSR))
+2 IF ACHSR=""
GOTO DSPEND
FILEDSPB ;
+1 SET ACHSRR=$ORDER(ACHSFILE("N",ACHSDTJL,ACHSR,ACHSRR))
+2 IF ACHSRR=""
GOTO FILEDSPA
+3 SET ACHSFNAM=$PIECE(ACHSFILE(ACHSRR),U,2)
SET ACHSXPT=0
SET ACHSXPT=$ORDER(^AFSTXLOG(DUZ(2),1,"B",ACHSFNAM,ACHSXPT))
+4 ;I +ACHSXPT<1 S ACHSEMSG="ERROR IN TX/EXPORT DATA STRUCTURE -- NOTIFY SUPERVISOR ",ACHSJFLG=1 G JCANCEL;IHS/SET/GTH ACHS*3.1*5 12/06/2002
+5 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
IF +ACHSXPT<1
WRITE !,"No entries for '",ACHSFNAM,"' for ",$$LOC^ACHS," in IHS DATA TRANSMISSION LOG file"
GOTO FILEDSPB
+6 SET ACHSZ=ACHSFILE(ACHSRR)
SET ACHSTXST="N"
SET $PIECE(ACHSFILE(ACHSRR),U,3)="N"
+7 ;S:+ACHSXPT>0 ACHSTXST=$P(^AFSTXLOG(DUZ(2),1,ACHSXPT,0),U,4),$P(ACHSFILE(ACHSRR),U,3)=ACHSTXST;IHS/SET/GTH ACHS*3.1*5 12/06/2002
+8 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
IF +ACHSXPT>0
SET ACHSTXST=$$GET1^DIQ(9002320.52,ACHSXPT_","_DUZ(2)_",",3,"I")
SET $PIECE(ACHSFILE(ACHSRR),U,3)=ACHSTXST
+9 ;S ACHSHCLR=$P(^AFSTXLOG(DUZ(2),1,ACHSXPT,0),U,5);IHS/SET/GTH ACHS*3.1*5 12/06/2002
+10 ;S ACHSHCLR=$S(ACHSHCLR="R":"RED",ACHSHCLR="B":"BLUE",1:"");IHS/SET/GTH ACHS*3.1*5 12/06/2002
+11 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
SET ACHSHCLR=$$GET1^DIQ(9002320.52,ACHSXPT_","_DUZ(2)_",",3.11)
+12 SET X=$PIECE($PIECE(ACHSFILE(ACHSRR),".",2),U,1)
+13 SET Y=$$GDT^ACHS(X)
+14 SET X=$PIECE(ACHSFILE(ACHSRR),U,1)
SET Z=X/81
SET X=$JUSTIFY(Z,0,0)
+15 SET ACHSSEQ=ACHSSEQ+1
+16 WRITE $JUSTIFY(ACHSSEQ,3),?6,$JUSTIFY(X,6),?17,Y
+17 SET Z=$PIECE(ACHSFILE(ACHSRR),U,2)
SET ACHSZZ1=$PIECE($PIECE(ACHSZ,U,2),".",1)
SET X=$PIECE(Z,".",1)
+18 WRITE ?33,$EXTRACT(X,1,ACHSFNLN),?45,$EXTRACT(X,ACHSFNLN+1,ACHSFNLN+1),?51,ACHSTXST,?57,ACHSHCLR,!
+19 GOTO FILEDSPB
+20 ;
DSPEND ;
+1 SET Y=$$DIR^XBDIR("Y","Do you want to Continue","Y")
+2 IF Y=0
SET %="M9"
SET ACHSEMSG=$PIECE($TEXT(@%^ACHSTCK1),";;",2)
SET ACHSJFLG=1
GOTO JCANCEL
+3 SET X=$EXTRACT(ACHSZZ1,$LENGTH(ACHSZZ1),$LENGTH(ACHSZZ1))
SET Y=$ASCII(X)
SET X=$CHAR(Y+1)
NAMEGEN ;
+1 ;S ACHSEXFN=ACHSZDIR_"/"_ACHSUXFP_ACHSXX_X_"."_ACHSDTJL,ACHSEXFS=ACHSUXFP_ACHSXX_X_"."_ACHSDTJL ;ACHS*3.1*22
+2 ;ACHS*3.1*22 IHS.OIT.FCJ
SET ACHSEXFN=ACHSZDIR_$SELECT($$OS^ACHS=2:"\",1:"/")_ACHSUXFP_ACHSXX_X_"."_ACHSDTJL
+3 ;ACHS*3.1*22
SET ACHSEXFS=ACHSUXFP_ACHSXX_X_"."_ACHSDTJL
+4 QUIT
+5 ;
JCANCEL ;
+1 USE IO(0)
+2 WRITE *7,!!,ACHSEMSG,!
+3 IF $$DIR^XBDIR("E","Press RETURN...")
+4 SET ACHSJFLG=1
+5 QUIT
+6 ;
