ECXDEFIN ;ALB/JAP,BIR/DMA-Define Extract Formats for Auto Queuing ; 17 Mar 95 / 9:55 AM
;;3.0;DSS EXTRACTS;**24**;Dec 22, 1997
EN ;entry point from option
N OUT,DIC,DIR,DIQ,DIRUT,DTOUT,DUOUT,DA,DR,X,Y,J,JJ
D MES^XPDUTL(" ")
D MES^XPDUTL("This option allows you to queue the generation of a specific DSS extract.")
D MES^XPDUTL("The extract will then be automatically requeued to run next month and")
D MES^XPDUTL("each subsequent month until the end of the fiscal year. It will be")
D MES^XPDUTL("requeued to run on the same day of each month at the same time of day.")
D MES^XPDUTL(" ")
S DIC="727.1",DIC(0)="AEQLMZ",ECF=0 D ^DIC
Q:Y<0 Q:$D(DTOUT) Q:$D(DUOUT)
S (DA,ECDA)=+Y,ECDATA=Y(0),ECROU=^ECX(727.1,ECDA,"ROU"),X="SETUP^"_ECROU D @X
I '$D(ECNODE) S ECNODE=7
;don't allow setup if more than 1 primary prosthetics division
I ECGRP="PRO" D Q:OUT>1
.S OUT=0,J=0
.S ECXDA1=$O(^ECX(728,0))
.F S J=$O(^ECX(728,ECXDA1,1,J)) Q:'J I $D(^ECX(728,ECXDA1,1,J,0)) S OUT=OUT+1
.I OUT>1 D
..D MES^XPDUTL(" ")
..D MES^XPDUTL("This DSS site is responsible for Prosthetics data from")
..D MES^XPDUTL("more than one Primary Prosthetics Division. Therefore,")
..D MES^XPDUTL("the PRO extract may not be setup for automatic requeue.")
..D MES^XPDUTL(" ")
..D MES^XPDUTL("Please use the Prosthetics Extract option on the Package")
..D MES^XPDUTL("Extracts menu to generate the monthly PRO extract for each")
..D MES^XPDUTL("Primary Prosthetics Division. Exiting...")
..D MES^XPDUTL(" ")
.I $E(IOST)="C" D
..S SS=22-$Y F JJ=1:1:SS W !
..S DIR(0)="E" W ! D ^DIR K DIR
;don't allow setup if extract has never been run or if 1st extract of fiscal year
I ECGRP'="PRO" D
.S ECLDT=$P($G(^ECX(728,1,ECNODE)),U,ECPIECE)
I ECGRP="PRO" D
.S ECLDT=""
.S ECXDA1=$O(^ECX(728,0))
.I $D(^ECX(728,ECXDA1,1,ECXINST,0)) S ECLDT=$P(^ECX(728,ECXDA1,1,ECXINST,0),U,2)
I ECLDT="" D MSG Q
S X=$$CYFY^ECXUTL1(DT)
I ECLDT=$$FMADD^XLFDT($P(X,U,3),-1) D MSG Q
;check if extract already queued to run
I $P(ECDATA,"^",6) D Q
.F J=1:1 S X=$P($T(WARN+J),";",3,300) Q:X="QUIT" W !,?5,X
.S DIR(0)="YA",DIR("A")="Do you wish to proceed? ",DIR("B")="N" K DIRUT,DUOUT,DTOUT
.D ^DIR K DIR
.I Y D QUEUE
D QUEUE
Q
;
QUEUE ;queue thru taskmanager
N ZTIO,ZTRTN,ZTDESC,ZTDTH,OUT,MONTH
D MES^XPDUTL(" ")
S OUT=0
F D Q:OUT
.D MES^XPDUTL(" ")
.S %DT="AEXR",%DT(0)=$$NOW^XLFDT+.0002,%DT("A")="Queue to run at what date/time? "
.D ^%DT K %DT
.S ECD=Y
.I ECD<0 S OUT=1
.I $E(ECD,6,7)>28 D Q
..D MES^XPDUTL(" ")
..D MES^XPDUTL("Monthly extracts must be queued for a date not greater than the 28th.")
..D MES^XPDUTL(" ")
.S OUT=1
I ECD>DT D
.S:'$D(ECINST) ECINST=+$P(^ECX(728,1,0),U)
.S ECXINST=ECINST
.K ECXDIC S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
.D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC
.;get last date for all extracts except prosthetics
.I ECGRP'="PRO" D
..S ECLDT=$S($D(^ECX(728,1,ECNODE)):$P(^(ECNODE),U,ECPIECE),1:2610624)
.;get last date for prosthetics
.I ECGRP="PRO" D
..S ECLDT=""
..S ECXDA1=$O(^ECX(728,0))
..I $D(^ECX(728,ECXDA1,1,ECXINST,0)) S ECLDT=$P(^ECX(728,ECXDA1,1,ECXINST,0),U,2)
.;ecldt should be valid so continue
.I ECLDT D Q:'$G(Y) Q:$D(DIRUT)
..S ECFDT=$$LASTMON(ECD)
..;change to 1st day of month
..S $E(ECFDT,6,7)="01"
..S ECDIF=$$FMDIFF^XLFDT(ECFDT,ECLDT)
..Q:ECDIF=1
..S Y=$E(ECFDT,1,5)_"00" D DD^%DT S MONTH=Y K Y
..D MES^XPDUTL(" ")
..D MES^XPDUTL("The last date for the "_ECHEAD_" extract was "_$$FMTE^XLFDT(ECLDT)_".")
..D MES^XPDUTL(" ")
..D MES^XPDUTL("When the extract is run using the queue date/time you supplied, data")
..D MES^XPDUTL("for the month of "_MONTH_" will be extracted.")
..D MES^XPDUTL(" ")
..I ECDIF>1 D MES^XPDUTL("It appears that there is a period of time for which data will not be extracted.")
..I ECDIF<0 D MES^XPDUTL("It appears that you may be duplicating previously extracted data.")
..D MES^XPDUTL(" ")
..S DIR(0)="YA",DIR("A")="Do you wish to proceed? ",DIR("B")="N" K DIRUT,DUOUT,DTOUT
..D ^DIR K DIR
.S ZTRTN="QUE^"_ECROU,ZTDESC=ECPACK_" EXTRACT",ZTIO="",ZTDTH=ECD
.D ^%ZTLOAD
.I $G(ZTSK) D
..S $P(^ECX(727.1,ECDA,0),"^",6)=1
..D MES^XPDUTL(" ")
..D MES^XPDUTL("Request queued as Task #"_ZTSK)
..D MES^XPDUTL("with automatic monthly requeue.")
..D MES^XPDUTL(" ")
..I $E(IOST)="C" D
...S SS=22-$Y F JJ=1:1:SS W !
...S DIR(0)="E" W ! D ^DIR K DIR
K ECD,ECDA,ECDATA,ECDIF,ECF,ECFDT,ECFILE,ECGRP,ECHEAD,ECLDT,ECPIECE,ECPACK,ECROU,ECINST,ECNODE,ECXDA1,ECXINST
Q
;
WARN ;
;;
;;It appears that the extract has already been queued to run. If you make
;;changes now, there is a possibility that data for a particular date range
;;may be omitted from the extract process and not transmitted to AAC.
;;
;;Before continuing, you should carefully review the extract history for
;;this extract. You should also verify that this extract is not currently
;;queued to run in the future.
;;
;;QUIT
;
MSG ;
D MES^XPDUTL(" ")
I ECLDT="" D
.D MES^XPDUTL("Automatic requeue may not be setup for a DSS extract")
.D MES^XPDUTL("which has never been previously generated.")
I ECLDT D
.D MES^XPDUTL("Automatic requeue may not be setup to generate the October")
.D MES^XPDUTL("extract of the current fiscal year.")
D MES^XPDUTL(" ")
D MES^XPDUTL("Please use the appropriate option on the Package Extracts")
D MES^XPDUTL("menu to generate the first monthly "_ECHEAD_" extract of")
D MES^XPDUTL("the current fiscal year. Exiting...")
D MES^XPDUTL(" ")
I $E(IOST)="C" D
.S SS=22-$Y F JJ=1:1:SS W !
.S DIR(0)="E" W ! D ^DIR K DIR
Q
;
NEXTMON(ECXDATE) ;get date for date+(1 month)
;input ECXDATE = FM date or date/time [required]
; where day of month is cannot be greater than 28
;output returns FM date or date/time; next month, but same day of month
N DATE,ECXNEXT,X1,X2,X
S DATE=$P(ECXDATE,".")
I +$E(DATE,6,7)>28 S $E(DATE,6,7)="28"
S X1=DATE,X2=30 D C^%DTC
S ECXNEXT=X
I $E(ECXNEXT,6,7)'=$E(ECXDATE,6,7) S $E(ECXNEXT,6,7)=$E(ECXDATE,6,7)
I $P(ECXDATE,".",2) S $P(ECXNEXT,".",2)=$P(ECXDATE,".",2)
Q ECXNEXT
;
LASTMON(ECXDATE) ;get last day of previous month
;input ECXDATE = FM date or date/time [required]
;output returns FM date; previous month, last day of month
N DATE,ECXLAST,X1,X2,X
S DATE=$P(ECXDATE,"."),DATE=$E(DATE,1,5)_"01"
S X1=DATE,X2=-1 D C^%DTC
S ECXLAST=X
Q ECXLAST
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXDEFIN 6564 printed Apr 09, 2024@20:59:19 Page 2
ECXDEFIN ;ALB/JAP,BIR/DMA-Define Extract Formats for Auto Queuing ; 17 Mar 95 / 9:55 AM
+1 ;;3.0;DSS EXTRACTS;**24**;Dec 22, 1997
EN ;entry point from option
+1 NEW OUT,DIC,DIR,DIQ,DIRUT,DTOUT,DUOUT,DA,DR,X,Y,J,JJ
+2 DO MES^XPDUTL(" ")
+3 DO MES^XPDUTL("This option allows you to queue the generation of a specific DSS extract.")
+4 DO MES^XPDUTL("The extract will then be automatically requeued to run next month and")
+5 DO MES^XPDUTL("each subsequent month until the end of the fiscal year. It will be")
+6 DO MES^XPDUTL("requeued to run on the same day of each month at the same time of day.")
+7 DO MES^XPDUTL(" ")
+8 SET DIC="727.1"
SET DIC(0)="AEQLMZ"
SET ECF=0
DO ^DIC
+9 if Y<0
QUIT
if $DATA(DTOUT)
QUIT
if $DATA(DUOUT)
QUIT
+10 SET (DA,ECDA)=+Y
SET ECDATA=Y(0)
SET ECROU=^ECX(727.1,ECDA,"ROU")
SET X="SETUP^"_ECROU
DO @X
+11 IF '$DATA(ECNODE)
SET ECNODE=7
+12 ;don't allow setup if more than 1 primary prosthetics division
+13 IF ECGRP="PRO"
Begin DoDot:1
+14 SET OUT=0
SET J=0
+15 SET ECXDA1=$ORDER(^ECX(728,0))
+16 FOR
SET J=$ORDER(^ECX(728,ECXDA1,1,J))
if 'J
QUIT
IF $DATA(^ECX(728,ECXDA1,1,J,0))
SET OUT=OUT+1
+17 IF OUT>1
Begin DoDot:2
+18 DO MES^XPDUTL(" ")
+19 DO MES^XPDUTL("This DSS site is responsible for Prosthetics data from")
+20 DO MES^XPDUTL("more than one Primary Prosthetics Division. Therefore,")
+21 DO MES^XPDUTL("the PRO extract may not be setup for automatic requeue.")
+22 DO MES^XPDUTL(" ")
+23 DO MES^XPDUTL("Please use the Prosthetics Extract option on the Package")
+24 DO MES^XPDUTL("Extracts menu to generate the monthly PRO extract for each")
+25 DO MES^XPDUTL("Primary Prosthetics Division. Exiting...")
+26 DO MES^XPDUTL(" ")
End DoDot:2
+27 IF $EXTRACT(IOST)="C"
Begin DoDot:2
+28 SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
+29 SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
End DoDot:2
End DoDot:1
if OUT>1
QUIT
+30 ;don't allow setup if extract has never been run or if 1st extract of fiscal year
+31 IF ECGRP'="PRO"
Begin DoDot:1
+32 SET ECLDT=$PIECE($GET(^ECX(728,1,ECNODE)),U,ECPIECE)
End DoDot:1
+33 IF ECGRP="PRO"
Begin DoDot:1
+34 SET ECLDT=""
+35 SET ECXDA1=$ORDER(^ECX(728,0))
+36 IF $DATA(^ECX(728,ECXDA1,1,ECXINST,0))
SET ECLDT=$PIECE(^ECX(728,ECXDA1,1,ECXINST,0),U,2)
End DoDot:1
+37 IF ECLDT=""
DO MSG
QUIT
+38 SET X=$$CYFY^ECXUTL1(DT)
+39 IF ECLDT=$$FMADD^XLFDT($PIECE(X,U,3),-1)
DO MSG
QUIT
+40 ;check if extract already queued to run
+41 IF $PIECE(ECDATA,"^",6)
Begin DoDot:1
+42 FOR J=1:1
SET X=$PIECE($TEXT(WARN+J),";",3,300)
if X="QUIT"
QUIT
WRITE !,?5,X
+43 SET DIR(0)="YA"
SET DIR("A")="Do you wish to proceed? "
SET DIR("B")="N"
KILL DIRUT,DUOUT,DTOUT
+44 DO ^DIR
KILL DIR
+45 IF Y
DO QUEUE
End DoDot:1
QUIT
+46 DO QUEUE
+47 QUIT
+48 ;
QUEUE ;queue thru taskmanager
+1 NEW ZTIO,ZTRTN,ZTDESC,ZTDTH,OUT,MONTH
+2 DO MES^XPDUTL(" ")
+3 SET OUT=0
+4 FOR
Begin DoDot:1
+5 DO MES^XPDUTL(" ")
+6 SET %DT="AEXR"
SET %DT(0)=$$NOW^XLFDT+.0002
SET %DT("A")="Queue to run at what date/time? "
+7 DO ^%DT
KILL %DT
+8 SET ECD=Y
+9 IF ECD<0
SET OUT=1
+10 IF $EXTRACT(ECD,6,7)>28
Begin DoDot:2
+11 DO MES^XPDUTL(" ")
+12 DO MES^XPDUTL("Monthly extracts must be queued for a date not greater than the 28th.")
+13 DO MES^XPDUTL(" ")
End DoDot:2
QUIT
+14 SET OUT=1
End DoDot:1
if OUT
QUIT
+15 IF ECD>DT
Begin DoDot:1
+16 if '$DATA(ECINST)
SET ECINST=+$PIECE(^ECX(728,1,0),U)
+17 SET ECXINST=ECINST
+18 KILL ECXDIC
SET DA=ECINST
SET DIC="^DIC(4,"
SET DIQ(0)="I"
SET DIQ="ECXDIC"
SET DR=".01;99"
+19 DO EN^DIQ1
SET ECINST=$GET(ECXDIC(4,DA,99,"I"))
KILL DIC,DIQ,DA,DR,ECXDIC
+20 ;get last date for all extracts except prosthetics
+21 IF ECGRP'="PRO"
Begin DoDot:2
+22 SET ECLDT=$SELECT($DATA(^ECX(728,1,ECNODE)):$PIECE(^(ECNODE),U,ECPIECE),1:2610624)
End DoDot:2
+23 ;get last date for prosthetics
+24 IF ECGRP="PRO"
Begin DoDot:2
+25 SET ECLDT=""
+26 SET ECXDA1=$ORDER(^ECX(728,0))
+27 IF $DATA(^ECX(728,ECXDA1,1,ECXINST,0))
SET ECLDT=$PIECE(^ECX(728,ECXDA1,1,ECXINST,0),U,2)
End DoDot:2
+28 ;ecldt should be valid so continue
+29 IF ECLDT
Begin DoDot:2
+30 SET ECFDT=$$LASTMON(ECD)
+31 ;change to 1st day of month
+32 SET $EXTRACT(ECFDT,6,7)="01"
+33 SET ECDIF=$$FMDIFF^XLFDT(ECFDT,ECLDT)
+34 if ECDIF=1
QUIT
+35 SET Y=$EXTRACT(ECFDT,1,5)_"00"
DO DD^%DT
SET MONTH=Y
KILL Y
+36 DO MES^XPDUTL(" ")
+37 DO MES^XPDUTL("The last date for the "_ECHEAD_" extract was "_$$FMTE^XLFDT(ECLDT)_".")
+38 DO MES^XPDUTL(" ")
+39 DO MES^XPDUTL("When the extract is run using the queue date/time you supplied, data")
+40 DO MES^XPDUTL("for the month of "_MONTH_" will be extracted.")
+41 DO MES^XPDUTL(" ")
+42 IF ECDIF>1
DO MES^XPDUTL("It appears that there is a period of time for which data will not be extracted.")
+43 IF ECDIF<0
DO MES^XPDUTL("It appears that you may be duplicating previously extracted data.")
+44 DO MES^XPDUTL(" ")
+45 SET DIR(0)="YA"
SET DIR("A")="Do you wish to proceed? "
SET DIR("B")="N"
KILL DIRUT,DUOUT,DTOUT
+46 DO ^DIR
KILL DIR
End DoDot:2
if '$GET(Y)
QUIT
if $DATA(DIRUT)
QUIT
+47 SET ZTRTN="QUE^"_ECROU
SET ZTDESC=ECPACK_" EXTRACT"
SET ZTIO=""
SET ZTDTH=ECD
+48 DO ^%ZTLOAD
+49 IF $GET(ZTSK)
Begin DoDot:2
+50 SET $PIECE(^ECX(727.1,ECDA,0),"^",6)=1
+51 DO MES^XPDUTL(" ")
+52 DO MES^XPDUTL("Request queued as Task #"_ZTSK)
+53 DO MES^XPDUTL("with automatic monthly requeue.")
+54 DO MES^XPDUTL(" ")
+55 IF $EXTRACT(IOST)="C"
Begin DoDot:3
+56 SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
+57 SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
End DoDot:3
End DoDot:2
End DoDot:1
+58 KILL ECD,ECDA,ECDATA,ECDIF,ECF,ECFDT,ECFILE,ECGRP,ECHEAD,ECLDT,ECPIECE,ECPACK,ECROU,ECINST,ECNODE,ECXDA1,ECXINST
+59 QUIT
+60 ;
WARN ;
+1 ;;
+2 ;;It appears that the extract has already been queued to run. If you make
+3 ;;changes now, there is a possibility that data for a particular date range
+4 ;;may be omitted from the extract process and not transmitted to AAC.
+5 ;;
+6 ;;Before continuing, you should carefully review the extract history for
+7 ;;this extract. You should also verify that this extract is not currently
+8 ;;queued to run in the future.
+9 ;;
+10 ;;QUIT
+11 ;
MSG ;
+1 DO MES^XPDUTL(" ")
+2 IF ECLDT=""
Begin DoDot:1
+3 DO MES^XPDUTL("Automatic requeue may not be setup for a DSS extract")
+4 DO MES^XPDUTL("which has never been previously generated.")
End DoDot:1
+5 IF ECLDT
Begin DoDot:1
+6 DO MES^XPDUTL("Automatic requeue may not be setup to generate the October")
+7 DO MES^XPDUTL("extract of the current fiscal year.")
End DoDot:1
+8 DO MES^XPDUTL(" ")
+9 DO MES^XPDUTL("Please use the appropriate option on the Package Extracts")
+10 DO MES^XPDUTL("menu to generate the first monthly "_ECHEAD_" extract of")
+11 DO MES^XPDUTL("the current fiscal year. Exiting...")
+12 DO MES^XPDUTL(" ")
+13 IF $EXTRACT(IOST)="C"
Begin DoDot:1
+14 SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
+15 SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
End DoDot:1
+16 QUIT
+17 ;
NEXTMON(ECXDATE) ;get date for date+(1 month)
+1 ;input ECXDATE = FM date or date/time [required]
+2 ; where day of month is cannot be greater than 28
+3 ;output returns FM date or date/time; next month, but same day of month
+4 NEW DATE,ECXNEXT,X1,X2,X
+5 SET DATE=$PIECE(ECXDATE,".")
+6 IF +$EXTRACT(DATE,6,7)>28
SET $EXTRACT(DATE,6,7)="28"
+7 SET X1=DATE
SET X2=30
DO C^%DTC
+8 SET ECXNEXT=X
+9 IF $EXTRACT(ECXNEXT,6,7)'=$EXTRACT(ECXDATE,6,7)
SET $EXTRACT(ECXNEXT,6,7)=$EXTRACT(ECXDATE,6,7)
+10 IF $PIECE(ECXDATE,".",2)
SET $PIECE(ECXNEXT,".",2)=$PIECE(ECXDATE,".",2)
+11 QUIT ECXNEXT
+12 ;
LASTMON(ECXDATE) ;get last day of previous month
+1 ;input ECXDATE = FM date or date/time [required]
+2 ;output returns FM date; previous month, last day of month
+3 NEW DATE,ECXLAST,X1,X2,X
+4 SET DATE=$PIECE(ECXDATE,".")
SET DATE=$EXTRACT(DATE,1,5)_"01"
+5 SET X1=DATE
SET X2=-1
DO C^%DTC
+6 SET ECXLAST=X
+7 QUIT ECXLAST
