203 lines
7.4 KiB
Mathematica
203 lines
7.4 KiB
Mathematica
ECXTRAC ;ALB/GTS,JAP,BIR/DMA,CML-Package Extracts for DSS ; 5/9/05 10:39am
|
|
;;3.0;DSS EXTRACTS;**9,8,14,24,30,33,49,84**;Dec 22, 1997
|
|
;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
|
|
F S EC=$O(^PS(59.5,EC)) Q:'EC I '$P(^PS(59.5,EC,0),U,4) D Q:CHKFLG
|
|
.S CHKFLG=$S('$G(^PS(59.5,EC,"I")):1,$G(^PS(59.5,EC,"I"))>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
|
|
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
|