source: FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXTRAC.m@ 1800

ECXTRAC ;ALB/GTS,JAP,BIR/DMA,CML-Package Extracts for DSS ; 7/29/07 12:51pm
 ;;3.0;DSS EXTRACTS;**9,8,14,24,30,33,49,84,105**;Dec 22, 1997;Build 70
 ;Date range, queuing and message sending for package extracts
 ;Input
 ;  ECPACK   printed name of package (e.g. Lab, Prescriptions)
 ;  ECNODE   in file 728 where last date is stored
 ;  ECPIECE  piece of node where last date is stored
 ;  ECRTN    in the form of START^ROUTINE
 ;  ECGRP    name of local mail group to receive summary message
 ;           (MUST BE 1 TO 5 UPPER CASE ALPHA - NO SPACES)
 ;  ECFILE   file number of the local editing file
 ;  ECXLOGIC Fiscal year extract logic to use (optional)
 ;  ECXDATES StartDate^EndDate^DoNotUpdate728 (optional)
 ;Generates
 ;  EC23=2nd and 3rd piece of zero node in local editing file
 ;      =YYMM of end date^pointer to 727
 ;  ECXLOGIC=Fiscal year extract logic to use
 ;
EN ;entry point
 N OUT,CHKFLG
 I '$D(ECNODE) S ECNODE=7
 I '$D(ECHEAD) S ECHEAD=" "
 I $P($G(^ECX(728,1,ECNODE+.1)),U,ECPIECE)]"" D  Q
 .W !!,$C(7),ECPACK," extract is already scheduled to run",!!
 .D PAUSE
 W @IOF,!,"Extract ",ECPACK," Information for DSS",!!
 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)
 .S:ECLDT="" ECLDT=2610624
 ;* get last date for prosthetics
 I ECGRP="PRO" D
 .N ECXDA1
 .S ECXDA1=$O(^ECX(728,0))
 .I $D(^ECX(728,ECXDA1,1,ECXINST,0)) D
 ..S ECLDT=$P(^ECX(728,ECXDA1,1,ECXINST,0),U,2)
 .I '$D(^ECX(728,ECXDA1,1,ECXINST,0)) D
 ..S DA(1)=ECXDA1
 ..S DIC(0)="L" K ECXDD
 ..D FIELD^DID(728,59,,"SPECIFIER","ECXDD")
 ..S DIC("P")=ECXDD("SPECIFIER") K ECXDD
 ..S DIC="^ECX(728,"_DA(1)_",1,",X=ECXINST,DINUM=X
 ..K DD,DO D FILE^DICN
 ..K DIC,X,DINUM,Y,DA
 ..S ECLDT=2610624
 S X=$G(ECXDATES) S ECSD=$P(X,"^",1),ECED=$P(X,"^",2)
 S OUT=0
 I (ECSD="")!(ECED="") F  S (ECED,ECSD)="" D  Q:OUT
 .K %DT S %DT="AEX",%DT("A")="Starting with Date: " D ^%DT
 .I Y<0 S OUT=1 Q
 .S ECSD=Y
 .K %DT S %DT="AEX",%DT("A")="Ending with Date: " D ^%DT
 .I Y<0 S OUT=1 Q
 .I Y<ECSD D  Q
 ..W !!,"The ending date cannot be earlier than the starting date."
 ..W !,"Please try again.",!!
 .I $E(Y,1,5)'=$E(ECSD,1,5) D  Q
 ..W !!,"Beginning and ending dates must be in the same month and year."
 ..W !,"Please try again.",!!
 .S ECED=Y
 .I ECLDT'<ECSD D  Q
 ..W !!,"The ",ECPACK," information has already been extracted through ",$$FMTE^XLFDT(ECLDT),"."
 ..W !,"Please enter a new date range.",!!
 .S OUT=1
 I ECED]"",ECSD]"" D QUE
 Q
 ;
QUE ;queue extract
 N CHKFLG
 ;if extract is ivp (i.e., file=727.819) and data in the intermediate file use new format
 I ECFILE=727.819 D  Q:CHKFLG
 .S CHKFLG=0
 .S X="PSIVSTAT" X ^%ZOSF("TEST") I '$T Q
 .I '$D(^ECX(728.113,"A")) S CHKFLG=1 D NOIVP Q
 .S DATE=$O(^ECX(728.113,"A",ECED+1),-1) I DATE<ECSD S CHKFLG=1 D NOIVP Q
 .D CHK^ECXDIVIV Q:CHKFLG
 .D CHK2
 .S ECRTN="START^ECXPIVDN",ECVER=7
 I '$D(ECNODE) S ECNODE=7
 I '$D(ECHEAD) S ECHEAD=""
 S ECSDN=$$FMTE^XLFDT(ECSD),ECEDN=$$FMTE^XLFDT(ECED),ECSD1=ECSD-.1
 K ZTSAVE
 F X="ECINST","ECED","ECSD","ECSD1","ECEDN","ECSDN" S ZTSAVE(X)=""
 F X="ECPACK","ECPIECE","ECRTN","ECGRP","ECNODE" S ZTSAVE(X)=""
 F X="ECFILE","ECHEAD","ECVER","ECINST","ECXINST" S ZTSAVE(X)=""
 F X="ECXLOGIC","ECXDATES" S ZTSAVE(X)=""
 S ZTDESC=ECPACK_" EXTRACT: "_ECSDN_" TO "_ECEDN,ZTRTN="START^ECXTRAC",ZTIO=""
 D ^%ZTLOAD
 I $D(ZTSK) D
 .S $P(^ECX(728,1,ECNODE+.1),U,ECPIECE)="R"
 .W !,"Request queued as Task #",ZTSK,".",!
 .D PAUSE
 Q
 ;
NOIVP ;cannot generate ivp message
 W !!,?5,"There does not appear to be any data in the IV EXTRACT DATA"
 W !,?5,"file (#728.113) for the selected date range."
 W !!,?5,"The IVP extract cannot be generated."
 D PAUSE
 Q
 ;
START ; entry when queued
 S QFLG=0
 L +^ECX(727,0) S EC=$P(^ECX(727,0),U,3)+1,$P(^(0),U,3,4)=EC_U_EC L -^ECX(727,0)
 S ^ECX(727,EC,0)=EC_U_DT_U_ECPACK_U_ECSD_U_$E(ECED,1,7)_U_U_DUZ
 S ^ECX(727,EC,"HEAD")=ECHEAD
 S:ECFILE=727.816 ECFILE=727.827 S ^ECX(727,EC,"FILE")=ECFILE
 S ^ECX(727,EC,"GRP")=ECGRP
 I $G(ECXLOGIC)="" S ECXLOGIC=$$FISCAL^ECXUTL1(ECSD)
 S ^ECX(727,EC,"VER")=$G(ECVER)_"^"_ECXLOGIC
 S ^ECX(727,EC,"DIV")=ECXINST
 S DA=EC,DIK="^ECX(727," D IX^DIK K DIK,DA
 S ECRN=0,ECXYM=$$ECXYM^ECXUTL(ECED),EC23=ECXYM_U_EC
 S ECXSTART=$P($$HTE^XLFDT($H),":",1,2),ECXNOW=$H
 ;do specific extract
 D @ECRTN
 ;if task gets stop request, set ztstop and quit
 I QFLG D  Q
 .S $P(^ECX(728,1,ECNODE+.1),U,ECPIECE)="",ZTSTOP=1
 .D QKILL
 .D QMSG
 .D ^ECXKILL
 ;Set last date for extract
 I '$P($G(ECXDATES),"^",3) D
 .;* set last date for all extracts except prosthetics
 .I ECGRP'="PRO" S $P(^ECX(728,1,ECNODE),U,ECPIECE)=$P(ECED,".") Q
 .;* set last date for prosthetics
 .N ECXDA1
 .S ECXDA1=$O(^ECX(728,0))
 .S $P(^ECX(728,ECXDA1,1,ECXINST,0),U,2)=$P(ECED,".")
 S TIME=$P($$HTE^XLFDT($H),":",1,2)
 S $P(^ECX(727,$P(EC23,U,2),0),U,6)=ECRN
 ;set piece 3 and 4 of the zero node
 S ECLAST=$O(^ECX(ECFILE,99999999),-1),ECTOTAL=$P(^ECX(ECFILE,0),U,4)+ECRN,$P(^(0),U,3,4)=ECLAST_U_ECTOTAL K ECLAST,ECTOTAL
 D MSG
 S $P(^ECX(728,1,ECNODE+.1),U,ECPIECE)=""
 I $D(ZTQUEUED) S ZTREQ="@"
 Q
 ;
MSG ; send message to mail group 'DSS-ECGRP'
 S XMSUB=ECINST_" - "_ECPACK_" EXTRACT FOR DSS",XMDUZ="DSS SYSTEM"
 K XMY S XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))=""
 S ECMSG(1,0)="The DSS-"_ECPACK_" extract (#"_$P(EC23,U,2)_") for "_ECSDN
 S ECMSG(2,0)="through "_ECEDN_" was begun on "_$P(ECXSTART,"@")_" at "_$P(ECXSTART,"@",2)
 S ECMSG(3,0)="and completed on "_$P(TIME,"@")_" at "_$P(TIME,"@",2)_"."
 S ECMSG(4,0)=" "
 S ECMSG(5,0)="A total of "_ECRN_" records were written."
 S ECMSG(6,0)=" "
 S ECMSG(7,0)="Extract time was [HH:MM:SS] "_$$HDIFF^XLFDT($H,ECXNOW,3)
 S ECMSG(8,0)=" "
 S X=$E(ECXLOGIC,5) S X=$S((X="")!(X=" "):"",1:"revision "_X_" of ")
 S ECMSG(9,0)="The data was extracted using "_X_"fiscal year "_$E(ECXLOGIC,1,4)_" logic."
 S ECMSG(10,0)=" "
 S XMTEXT="ECMSG("
 D ^XMD
 Q
 ;
QMSG ; send abort message to mail group 'DSS-ECGRP'
 S XMSUB=ECINST_" - "_ECPACK_" EXTRACT FOR DSS",XMDUZ="DSS SYSTEM"
 K XMY S XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))=""
 S ECMSG(1,0)="The DSS-"_ECPACK_" extract (#"_$P(EC23,U,2)_") for "_ECSDN
 S ECMSG(2,0)="through "_ECEDN_" was begun on "_$P(ECXSTART,"@")_" at "_$P(ECXSTART,"@",2)_"."
 S ECMSG(3,0)=" "
 S ECMSG(4,0)="A user stop request was received by Taskmanager which caused processing"
 S ECMSG(5,0)="to terminate before completion.  Any records which may have been created"
 S ECMSG(6,0)="in file #"_ECFILE_" for this extract have been deleted."
 S ECMSG(7,0)=" "
 S XMTEXT="ECMSG("
 D ^XMD
 Q
 ;
QKILL ;delete records created for any extract stopped at user request
 N ECX,FILE,IEN,DA,DIK
 S FILE="^ECX("_ECFILE_","
 S ECX=$P(EC23,U,2)
 F  S IEN=$O(^ECX(ECFILE,999999999),-1) Q:($P(^ECX(ECFILE,IEN,0),U,3)'=ECX)  D
 .S DIK=FILE,DA=IEN D ^DIK
 Q
 ;
CHK2 ;iv extract check - all active iv rooms to have a division
 S EC=0
 D ALL^PSJ59P5(,"??","ECXIV")
 F  S EC=$O(^TMP($J,"ECXIV",EC)) Q:'EC  I '^(EC,19) D  I CHKFLG D EXIT Q
 .S CHKFLG=$S($G(^TMP($J,"ECXIV",EC,19)):1,$G(^(19))>DT:1,1:0)
 .I CHKFLG D
 ..W !!,"All active IV Rooms in the IV Room file (#59.5) must have a ""DIVISION""",!,"assigned to run this extract!"
 ..W !!,"This information can be entered using the DSS Extract Manager's Maintenance ",!,"option ""Enter/Edit IV Room Division""."
 ..D PAUSE
EXIT K ^TMP($J,"ECXIV")
 Q
 ;
PAUSE ;pause screen
 N DIR,X,Y
 S OUT=0
 I $E(IOST)="C" D
 .S SS=22-$Y F JJ=1:1:SS W !
 .S DIR(0)="E" W ! D ^DIR K DIR
 I 'Y S OUT=1
 W !!
 Q