ACHSEXUT.m

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       ;