- 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 ;