ECXAMOV ;ALB/JAP - MOV Extract Audit Report ;3/13/19 09:33
;;3.0;DSS EXTRACTS;**8,33,149,173,174**;Dec 22, 1997;Build 33
;
EN ;entry point for MOV extract audit report
N %X,%Y,X,Y,DIC,DA,DR,DIQ,DIR,ECXPORT,RCNT ;149
S ECXERR=0
;ecxaud=0 for 'extract' audit
S ECXHEAD="MOV",ECXAUD=0
W !!,"Setup for ",ECXHEAD," Extract Audit Report --",!!
;select extract
D AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD)
Q:ECXERR
;determine if facility is multidivisional
S DIC="^DG(43,",DA=1,DR="11;",DIQ="ECX",DIQ(0)="I" D EN^DIQ1
I +ECX(43,1,11,"I")=0 S ECXALL=1
I +ECX(43,1,11,"I")=1 D
.W !!
.S DIR(0)="Y",DIR("A")="Do you want the "_ECXHEAD_" extract audit report for all divisions"
.S DIR("B")="NO" D ^DIR K DIR
.I $G(DIRUT) S ECXERR=1 Q
.;if y=0 i.e., 'no', then ecxall=0 i.e., 'selected'
.S ECXALL=Y
I ECXERR=1 D Q
.W !!,?5,"Try again later... exiting.",!
.D AUDIT^ECXKILL
;select divisions/sites; all divisions if ecxall=1
S X=ECXARRAY("START") D ^%DT S ECXSTART=Y S X=ECXARRAY("END") D ^%DT S ECXEND=Y
D MOV^ECXDVSN(.ECXDIV,ECXALL,ECXSTART,ECXEND,.ECXERR)
I ECXERR=1 D Q
.W !!,?5,"Try again later... exiting.",!
.D AUDIT^ECXKILL
;determine output device and queue if requested
S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I $G(ECXPORT) D Q ;149 Section added
.K ^TMP($J,"ECXPORT")
.S RCNT=0
.D PROCESS
.D EXPDISP^ECXUTL1
.D AUDIT^ECXKILL
W !
S ECXPGM="PROCESS^ECXAMOV",ECXDESC="MOV Extract Audit Report"
S ECXSAVE("ECXHEAD")="",ECXSAVE("ECXALL")="",ECXSAVE("ECXDIV(")="",ECXSAVE("ECXARRAY(")=""
W !!,?5,"The format of this report requires a page or screen",!,?5,"width of 132 characters.",!
D DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE)
I ECXSAVE("POP")=1 D Q
.W !!,?5,"Try again later... exiting.",!
.D AUDIT^ECXKILL
I ECXSAVE("ZTSK")=0 D
.K ECXSAVE,ECXPGM,ECXDESC
.D PROCESS^ECXAMOV
I IO'=IO(0) D ^%ZISC
D HOME^%ZIS
D AUDIT^ECXKILL
Q
;
PROCESS ;process data in file #727.808
N X,Y,W,JJ,DATE,DATA,DIV,IEN,MOV,TL,ORDER,SORD,GTOT,STOT,WARD,TMOV,QQFLG,CNT,LINETOT
K ^TMP($J,"ECXWARD"),^TMP($J,"ECXORDER"),^TMP($J,"MISWRD")
S (CNT,QQFLG)=0
S ECXEXT=ECXARRAY("EXTRACT"),ECXDEF=ECXARRAY("DEF")
S X=ECXARRAY("START") D ^%DT S ECXSTART=Y S X=ECXARRAY("END") D ^%DT S ECXEND=Y
;get run date in external format
D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S ECXRUN=Y
;get ward info in ^tmp($j,"ecxward" and ^tmp($j,"ecxorder"
D WARDS^ECXUTLA(ECXALL,.ECXDIV)
;setup up ^tmp($j,"mov", for legend
S JJ=0 F S JJ=$O(^DG(405.2,JJ)) Q:+JJ<1 S MOV=JJ D
.S DATA=^DG(405.2,JJ,0),NM=$P(DATA,U,1),TYPE=$P(DATA,U,2)
.S ^TMP($J,"MOV",TYPE,JJ)=NM
F JJ=1:1:MOV S $P(TL,U,JJ)=0
S W="" F S W=$O(^TMP($J,"ECXWARD",W)) Q:W="" D
.S DIV=$P(^TMP($J,"ECXWARD",W),U,3) I '$D(GTOT(DIV)) F JJ=1:1:MOV S $P(GTOT(DIV),U,JJ)=0
.S ^TMP($J,"TL",W)=TL
.S ORDER="" D
..F S ORDER=$O(^TMP($J,"ECXORDER",DIV,ORDER)) Q:ORDER="" I $D(^(ORDER,1)) D
...F JJ=1:1:MOV S $P(STOT(DIV,ORDER),U,JJ)=0
;get records in date range and ward set
S IEN="" F S IEN=$O(^ECX(727.808,"AC",ECXEXT,IEN)) Q:IEN="" D Q:QQFLG
.S DATA=^ECX(727.808,IEN,0),DATE=$P(DATA,U,9),WARD=$P(DATA,U,15),TMOV=$P(DATA,U,19)
.;convert free text date to fm internal format date
.S $E(DATE,1,2)=$E(DATE,1,2)-17
.Q:$L(DATE)<7 Q:(DATE<ECXSTART) Q:(DATE>ECXEND)
.;track missing wards
.I WARD="" D Q
..S ^TMP($J,"MISWRD")=$G(^TMP($J,"MISWRD"))+1,^("MISWRD",IEN)=""
.;if ward is among those selected, then tally movement data
.I $D(^TMP($J,"TL",WARD)) D
..S $P(^TMP($J,"TL",WARD),U,TMOV)=$P(^TMP($J,"TL",WARD),U,TMOV)+1
..S ORDER=$P(^TMP($J,"ECXWARD",WARD),U,1),DIV=$P(^(WARD),U,3),$P(GTOT(DIV),U,TMOV)=$P(GTOT(DIV),U,TMOV)+1
..S SORD=ORDER-.01,SORD=$O(STOT(DIV,SORD)) I +SORD S $P(STOT(DIV,SORD),U,TMOV)=$P(STOT(DIV,SORD),U,TMOV)+1
..S CNT=CNT+1 I $D(ZTQUEUED),(CNT>499),'(CNT#500),$$S^%ZTLOAD S QQFLG=1,ZTSTOP=1 K ZTREQ
;after all the extract records are processed, set totals into ^tmp($j,"ecxorder"
I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q
S W="" F S W=$O(^TMP($J,"TL",W)) Q:W="" S TL(W)=^(W) D
.S ORDER=$P(^TMP($J,"ECXWARD",W),U,1),DIV=$P(^(W),U,3)
.S LINETOT=0 F JJ=1:1:MOV S $P(^TMP($J,"ECXORDER",DIV,ORDER),U,JJ+2)=$P(TL(W),U,JJ),LINETOT=LINETOT+$P(TL(W),U,JJ)
.K TL(W)
.;don't keep inactive wards unless there is movement data
.I ORDER>999990,LINETOT=0 K ^TMP($J,"ECXORDER",DIV,ORDER)
.I $D(^TMP($J,"ECXORDER",DIV,ORDER,1)) D
..;don't do group total on inactive/unordered wards
..I ORDER>999990 K ^TMP($J,"ECXORDER",DIV,ORDER,1) Q
..F JJ=1:1:MOV S $P(^TMP($J,"ECXORDER",DIV,ORDER,1),U,JJ+2)=$P(STOT(DIV,ORDER),U,JJ)
D PRINT
I $G(ECXPORT) Q ;149
D AUDIT^ECXKILL
Q
;
PRINT ;print the movement data by division and ward order
N JJ,SS,LN,NM,TNM,PG,QFLG,WRDNM,WRDTOT,GRPNM,GRPTOT,DIVTOT,DATA,DATA1
N TYPE,DIC,DA,DR,DIR,DIRUT,DTOUT,DUOUT,W1,W2,ADMDT,IEN,FAC
U IO
I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q
S (QFLG,PG)=0,$P(LN,"-",132)="",DIV=""
F S DIV=$O(GTOT(DIV)) Q:DIV="" D Q:QFLG
.F TYPE=2,3 S TNM=$S(TYPE=2:"Transfer",TYPE=3:"Discharge",1:"") D HEADER Q:QFLG S MOV="",DIVTOT=0 D Q:QFLG
..I $G(ECXPORT) D ;149 Section added
...I TYPE=2 S ^TMP($J,"ECXPORT",RCNT)="EXTRACT LOG #^DIVISION^WARD <DSS DEPT>^1^2^3^4^13^14^22^23^24^25^26^43^44^45^TRANSFER TOTALS",RCNT=RCNT+1
...I TYPE=3 S ^TMP($J,"ECXPORT",RCNT)="EXTRACT LOG #^DIVISION^WARD^10^11^12^16^17^21^27^31^32^33^34^35^37^38^41^42^46^47^DISCHARGE TOTALS",RCNT=RCNT+1 ;149
..F S MOV=$O(^TMP($J,"MOV",TYPE,MOV)) Q:MOV="" S DIVTOT=DIVTOT+$P(GTOT(DIV),U,MOV)
..I DIVTOT=0 D Q
...I $G(ECXPORT) D Q ;149 Section added
....S ^TMP($J,"ECXPORT",RCNT)=ECXEXT_U_$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")"_U_"No "_TNM_" data extracted for this medical center division",RCNT=RCNT+1
....S ^TMP($J,"ECXPORT",RCNT)=$$REPEAT^XLFSTR("*",80),RCNT=RCNT+1
...W !!,"No "_TNM_" data extracted for this medical center division.",!
..S ORDER="" F S ORDER=$O(^TMP($J,"ECXORDER",DIV,ORDER)) Q:ORDER="" D Q:QFLG
...S DATA=^TMP($J,"ECXORDER",DIV,ORDER) K DATA1 I $D(^(ORDER,1)) S DATA1=^(1)
...S WRDNM=$P(DATA,U,2)
...I TYPE=3 S WRDNM=$P(WRDNM,"<",1),WRDNM=$E(WRDNM,1,14)
...I TYPE=2 D
....S W1=$P(WRDNM,"<",1),W2=$P(WRDNM,"<",2)
....S:W2="" WRDNM=$E(W1,1,14) S:W2]"" WRDNM=$$LJ^XLFSTR($E(W1,1,12),12," ")_" <"_W2
...D:($Y+3>IOSL) HEADER Q:QFLG
...W:'$G(ECXPORT) !,WRDNM S TAB=$S(TYPE=2:20,1:10),LINETOT=0 ;149
...I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)=ECXEXT_U_$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")"_U_$P(DATA,U,2) ;149
...F S MOV=$O(^TMP($J,"MOV",TYPE,MOV)) Q:MOV="" D
....S WRDTOT=$P(DATA,U,2+MOV),TAB=TAB+6 W:'$G(ECXPORT) ?TAB,$$RJ^XLFSTR(WRDTOT,5," ") S LINETOT=LINETOT+WRDTOT ;149
....I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)=^TMP($J,"ECXPORT",RCNT)_U_WRDTOT ;149
...I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)=^TMP($J,"ECXPORT",RCNT)_U_LINETOT,RCNT=RCNT+1 ;149
...S TAB=TAB+8 W:'$G(ECXPORT) ?TAB,$$RJ^XLFSTR(LINETOT,5," ") ;149
...;if data1 exists, then this is the end of a ward group so print group totals
...I $G(DATA1) D Q:QFLG
....S GRPNM=$P(DATA1,U,2) D:($Y+3>IOSL) HEADER Q:QFLG
....I '$G(ECXPORT) W !,?18,$E(LN,1,113) ;149
....I '$G(ECXPORT) D:($Y+3>IOSL) HEADER Q:QFLG W !,"Ward group "_GRPNM_" subtotals:",! ;149
....I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^^"_"Ward Group "_GRPNM_$S(TYPE=2:" transfer",1:" discharge")_" subtotals" ;149
....D:($Y+3>IOSL) HEADER Q:QFLG
....S TAB=$S(TYPE=2:20,1:10),LINETOT=0
....F S MOV=$O(^TMP($J,"MOV",TYPE,MOV)) Q:MOV="" D
.....S GRPTOT=$P(DATA1,U,2+MOV),TAB=TAB+6 W:'$G(ECXPORT) ?TAB,$$RJ^XLFSTR(GRPTOT,5," ") S LINETOT=LINETOT+GRPTOT ;149
.....I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)=^TMP($J,"ECXPORT",RCNT)_U_GRPTOT ;149
....I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)=^TMP($J,"ECXPORT",RCNT)_U_LINETOT,RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1 ;149
....S TAB=TAB+8 W:'$G(ECXPORT) ?TAB,$$RJ^XLFSTR(LINETOT,5," ") ;149
....D:($Y+3>IOSL) HEADER Q:QFLG
....I '$G(ECXPORT) W !! ;149
..Q:QFLG
..I '$G(ECXPORT) D:($Y+3>IOSL) HEADER Q:QFLG W !!,"Division "_$P(ECXDIV(DIV),U,2)_" Grand Totals:",! ;149
..I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1 S ^TMP($J,"ECXPORT",RCNT)="^"_"Division "_$P(ECXDIV(DIV),U,2)_" Grand Totals^" ;149
..D:($Y+3>IOSL) HEADER Q:QFLG
..S TAB=$S(TYPE=2:20,1:10),LINETOT=0
..F S MOV=$O(^TMP($J,"MOV",TYPE,MOV)) Q:MOV="" D
...S GTOT=$P(GTOT(DIV),U,MOV),TAB=TAB+6 W:'$G(ECXPORT) ?TAB,$$RJ^XLFSTR(GTOT,5," ") S LINETOT=LINETOT+GTOT ;149
...I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)=^TMP($J,"ECXPORT",RCNT)_U_GTOT ;149
..I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)=^TMP($J,"ECXPORT",RCNT)_U_LINETOT,RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)=$$REPEAT^XLFSTR("*",80),RCNT=RCNT+1 Q ;149
..S TAB=TAB+8 W ?TAB,$$RJ^XLFSTR(LINETOT,5," ")
..I $E(IOST)'="C" D LEGEND
;print patients with missing wards
I $D(^TMP($J,"MISWRD")) D
.S DIV="MISWRD",ECXDIV(DIV)="^^^^^*** MISSING WARDS ***^",TYPE=0
.D HEADER S WRDTOT=$G(^TMP($J,"MISWRD"))
.I $G(ECXPORT) D ;173
..S ^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^^MISSING WARD"_U_WRDTOT,RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1 ;149,173
..S ^TMP($J,"ECXPORT",RCNT)="^NOTE: Records are generated in the extract for ASIH Other Facility movement types.",RCNT=RCNT+1 ;173,174
..S ^TMP($J,"ECXPORT",RCNT)="^If present in your facility, this report will display them. Missing wards",RCNT=RCNT+1 ;173,174
..S ^TMP($J,"ECXPORT",RCNT)="^for ASIH Other Facility patients REQUIRE NO ACTION because the patient",RCNT=RCNT+1 ;173,174
..S ^TMP($J,"ECXPORT",RCNT)="^is at another facility.",RCNT=RCNT+1 ;174
..S ^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1 ;173
..S ^TMP($J,"ECXPORT",RCNT)="^NAME^PATIENT DFN^FACILITY^ADMISSION DATE^ASIH OTHER FACILITY MOVEMENT",RCNT=RCNT+1 ;173
.I '$G(ECXPORT) D ;149,173
..W !,?5,"MISSING WARD",?45,$$RJ^XLFSTR(WRDTOT,5," "),!! ;149,173
..W "NOTE: Records are generated in the extract for ASIH Other Facility movement types. If present in your facility, this report will",!,"display them. Missing Wards for ASIH Other Facility" ;173,174
..W " patients REQUIRE NO ACTION because the patient is at another facility.",! ;174
.D:'$G(ECXPORT) HEAD S IEN="" ;149
.F S IEN=$O(^TMP($J,"MISWRD",IEN)) Q:'IEN D I QFLG Q
..S DATA=$G(^ECX(727.808,IEN,0)),ADMDT=$P(DATA,U,11) Q:DATA=""
..S FAC=$P(DATA,U,4) S:FAC'="" FAC=$$GET1^DIQ(40.8,FAC,.01,"E") ;173
..I $G(ECXPORT) D Q ;173
...S ^TMP($J,"ECXPORT",RCNT)="^"_$P(DATA,U,7)_U_$P(DATA,U,5)_U_FAC_U_$E(ADMDT,5,6)_"/"_$E(ADMDT,7,8)_"/"_$E(ADMDT,1,4)_" "_$E($P(DATA,U,22),1,2)_":"_$E($P(DATA,U,22),3,4)_U_$S($P(DATA,U,8)="A":"YES",1:"NO"),RCNT=RCNT+1 ;149,173
..W !?2,$P(DATA,U,7),?8,$P(DATA,U,5),?25,$E(FAC,1,14),?45
..W $E(ADMDT,5,6)_"/"_$E(ADMDT,7,8)_"/"_$E(ADMDT,1,4)," "
..W $E($P(DATA,U,22),1,2)_":"_$E($P(DATA,U,22),3,4)
..W ?65,$S($P(DATA,U,8)="A":"YES",1:"NO") ;173 Is this an ASIH mvmt
..I '$G(ECXPORT) D:($Y+3>IOSL) HEADER,HEAD Q:QFLG ;149
I $G(ECXPORT) Q ;149
I $E(IOST)'="C" D
.W @IOF S PG=PG+1
.W !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report"
.W !,"DSS Extract Log #: "_ECXEXT
.W !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END")
.W !,"Report Run Date/Time: "_ECXRUN,?120,"Page: ",PG
.W !!,LN,!!
.S DIC="^ECX(727.1,",DA=ECXARRAY("DEF"),DR="1" D EN^DIQ
I $E(IOST)="C",'QFLG D
.S SS=22-$Y F JJ=1:1:SS W !
.S DIR(0)="E" W ! D ^DIR K DIR
Q
;
HEAD ;header for missing wards
W !,?2,"NAME",?8,"PATIENT DFN",?25,"FACILITY",?45,"ADMISSION DATE",?65,"ASIH OTHER FACILITY" ;173
W !,?2,"====",?8,"===========",?25,"========",?45,"==============",?65,"===================" ;173
Q
;
N JJ,SS,TAB,DSSID
I $G(QFLG)!($G(ECXPORT)) Q ;149
I $E(IOST)="C" D
.S SS=22-$Y F JJ=1:1:SS W !
.I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1
Q:QFLG
S DSSID=$P(ECXDIV(DIV),U,6)
W:$Y!($E(IOST)="C") @IOF S PG=PG+1
W !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report"
W !,"DSS Extract Log #: "_ECXEXT
W !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END")
W !,"Report Run Date/Time: "_ECXRUN
I DSSID="" W !,"Medical Center Division: "_$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")",?120,"Page: "_PG
I DSSID]"" W !,"Medical Center Division: "_$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")"_" <"_DSSID_">",?120,"Page: "_PG
S TAB=$S(TYPE=2:28,1:20) W !!
I TYPE=2 W "Ward <DSS Dept.>",?TAB,"MAS Movement ("_TNM_") Types",!
I TYPE=3 W "Ward",?TAB,"MAS Movement ("_TNM_") Types",!
S MOV="",TAB=$S(TYPE=0:40,TYPE=2:20,1:10)
F S MOV=$O(^TMP($J,"MOV",TYPE,MOV)) Q:MOV="" S TAB=TAB+6 W ?TAB,$$RJ^XLFSTR(MOV,5," ")
S TAB=TAB+8 W ?TAB,$$RJ^XLFSTR("Total",5," ")
W !,LN,!
Q
;
LEGEND ;print legend for each report type
N MOV,MOVNM
D:($Y+10>IOSL) HEADER
W !!,TNM_" Movements Legend --"
S MOV="" F S MOV=$O(^TMP($J,"MOV",TYPE,MOV)) Q:MOV="" D Q:MOV=""
.S MOVNM=^TMP($J,"MOV",TYPE,MOV) W !,MOV,?4,"= ",$E(MOVNM,1,32)
.S MOV=$O(^TMP($J,"MOV",TYPE,MOV)) Q:MOV="" S MOVNM=^(MOV) W ?41,MOV,?44,"= ",$E(MOVNM,1,32)
.S MOV=$O(^TMP($J,"MOV",TYPE,MOV)) Q:MOV="" S MOVNM=^(MOV) W ?81,MOV,?84,"= ",$E(MOVNM,1,32)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXAMOV 13297 printed Apr 09, 2024@20:56:24 Page 2
ECXAMOV ;ALB/JAP - MOV Extract Audit Report ;3/13/19 09:33
+1 ;;3.0;DSS EXTRACTS;**8,33,149,173,174**;Dec 22, 1997;Build 33
+2 ;
EN ;entry point for MOV extract audit report
+1 ;149
NEW %X,%Y,X,Y,DIC,DA,DR,DIQ,DIR,ECXPORT,RCNT
+2 SET ECXERR=0
+3 ;ecxaud=0 for 'extract' audit
+4 SET ECXHEAD="MOV"
SET ECXAUD=0
+5 WRITE !!,"Setup for ",ECXHEAD," Extract Audit Report --",!!
+6 ;select extract
+7 DO AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD)
+8 if ECXERR
QUIT
+9 ;determine if facility is multidivisional
+10 SET DIC="^DG(43,"
SET DA=1
SET DR="11;"
SET DIQ="ECX"
SET DIQ(0)="I"
DO EN^DIQ1
+11 IF +ECX(43,1,11,"I")=0
SET ECXALL=1
+12 IF +ECX(43,1,11,"I")=1
Begin DoDot:1
+13 WRITE !!
+14 SET DIR(0)="Y"
SET DIR("A")="Do you want the "_ECXHEAD_" extract audit report for all divisions"
+15 SET DIR("B")="NO"
DO ^DIR
KILL DIR
+16 IF $GET(DIRUT)
SET ECXERR=1
QUIT
+17 ;if y=0 i.e., 'no', then ecxall=0 i.e., 'selected'
+18 SET ECXALL=Y
End DoDot:1
+19 IF ECXERR=1
Begin DoDot:1
+20 WRITE !!,?5,"Try again later... exiting.",!
+21 DO AUDIT^ECXKILL
End DoDot:1
QUIT
+22 ;select divisions/sites; all divisions if ecxall=1
+23 SET X=ECXARRAY("START")
DO ^%DT
SET ECXSTART=Y
SET X=ECXARRAY("END")
DO ^%DT
SET ECXEND=Y
+24 DO MOV^ECXDVSN(.ECXDIV,ECXALL,ECXSTART,ECXEND,.ECXERR)
+25 IF ECXERR=1
Begin DoDot:1
+26 WRITE !!,?5,"Try again later... exiting.",!
+27 DO AUDIT^ECXKILL
End DoDot:1
QUIT
+28 ;determine output device and queue if requested
+29 ;149 Section added
SET ECXPORT=$$EXPORT^ECXUTL1
if ECXPORT=-1
QUIT
IF $GET(ECXPORT)
Begin DoDot:1
+30 KILL ^TMP($JOB,"ECXPORT")
+31 SET RCNT=0
+32 DO PROCESS
+33 DO EXPDISP^ECXUTL1
+34 DO AUDIT^ECXKILL
End DoDot:1
QUIT
+35 WRITE !
+36 SET ECXPGM="PROCESS^ECXAMOV"
SET ECXDESC="MOV Extract Audit Report"
+37 SET ECXSAVE("ECXHEAD")=""
SET ECXSAVE("ECXALL")=""
SET ECXSAVE("ECXDIV(")=""
SET ECXSAVE("ECXARRAY(")=""
+38 WRITE !!,?5,"The format of this report requires a page or screen",!,?5,"width of 132 characters.",!
+39 DO DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE)
+40 IF ECXSAVE("POP")=1
Begin DoDot:1
+41 WRITE !!,?5,"Try again later... exiting.",!
+42 DO AUDIT^ECXKILL
End DoDot:1
QUIT
+43 IF ECXSAVE("ZTSK")=0
Begin DoDot:1
+44 KILL ECXSAVE,ECXPGM,ECXDESC
+45 DO PROCESS^ECXAMOV
End DoDot:1
+46 IF IO'=IO(0)
DO ^%ZISC
+47 DO HOME^%ZIS
+48 DO AUDIT^ECXKILL
+49 QUIT
+50 ;
PROCESS ;process data in file #727.808
+1 NEW X,Y,W,JJ,DATE,DATA,DIV,IEN,MOV,TL,ORDER,SORD,GTOT,STOT,WARD,TMOV,QQFLG,CNT,LINETOT
+2 KILL ^TMP($JOB,"ECXWARD"),^TMP($JOB,"ECXORDER"),^TMP($JOB,"MISWRD")
+3 SET (CNT,QQFLG)=0
+4 SET ECXEXT=ECXARRAY("EXTRACT")
SET ECXDEF=ECXARRAY("DEF")
+5 SET X=ECXARRAY("START")
DO ^%DT
SET ECXSTART=Y
SET X=ECXARRAY("END")
DO ^%DT
SET ECXEND=Y
+6 ;get run date in external format
+7 DO NOW^%DTC
SET Y=$EXTRACT(%,1,12)
DO DD^%DT
SET ECXRUN=Y
+8 ;get ward info in ^tmp($j,"ecxward" and ^tmp($j,"ecxorder"
+9 DO WARDS^ECXUTLA(ECXALL,.ECXDIV)
+10 ;setup up ^tmp($j,"mov", for legend
+11 SET JJ=0
FOR
SET JJ=$ORDER(^DG(405.2,JJ))
if +JJ<1
QUIT
SET MOV=JJ
Begin DoDot:1
+12 SET DATA=^DG(405.2,JJ,0)
SET NM=$PIECE(DATA,U,1)
SET TYPE=$PIECE(DATA,U,2)
+13 SET ^TMP($JOB,"MOV",TYPE,JJ)=NM
End DoDot:1
+14 FOR JJ=1:1:MOV
SET $PIECE(TL,U,JJ)=0
+15 SET W=""
FOR
SET W=$ORDER(^TMP($JOB,"ECXWARD",W))
if W=""
QUIT
Begin DoDot:1
+16 SET DIV=$PIECE(^TMP($JOB,"ECXWARD",W),U,3)
IF '$DATA(GTOT(DIV))
FOR JJ=1:1:MOV
SET $PIECE(GTOT(DIV),U,JJ)=0
+17 SET ^TMP($JOB,"TL",W)=TL
+18 SET ORDER=""
Begin DoDot:2
+19 FOR
SET ORDER=$ORDER(^TMP($JOB,"ECXORDER",DIV,ORDER))
if ORDER=""
QUIT
IF $DATA(^(ORDER,1))
Begin DoDot:3
+20 FOR JJ=1:1:MOV
SET $PIECE(STOT(DIV,ORDER),U,JJ)=0
End DoDot:3
End DoDot:2
End DoDot:1
+21 ;get records in date range and ward set
+22 SET IEN=""
FOR
SET IEN=$ORDER(^ECX(727.808,"AC",ECXEXT,IEN))
if IEN=""
QUIT
Begin DoDot:1
+23 SET DATA=^ECX(727.808,IEN,0)
SET DATE=$PIECE(DATA,U,9)
SET WARD=$PIECE(DATA,U,15)
SET TMOV=$PIECE(DATA,U,19)
+24 ;convert free text date to fm internal format date
+25 SET $EXTRACT(DATE,1,2)=$EXTRACT(DATE,1,2)-17
+26 if $LENGTH(DATE)<7
QUIT
if (DATE<ECXSTART)
QUIT
if (DATE>ECXEND)
QUIT
+27 ;track missing wards
+28 IF WARD=""
Begin DoDot:2
+29 SET ^TMP($JOB,"MISWRD")=$GET(^TMP($JOB,"MISWRD"))+1
SET ^("MISWRD",IEN)=""
End DoDot:2
QUIT
+30 ;if ward is among those selected, then tally movement data
+31 IF $DATA(^TMP($JOB,"TL",WARD))
Begin DoDot:2
+32 SET $PIECE(^TMP($JOB,"TL",WARD),U,TMOV)=$PIECE(^TMP($JOB,"TL",WARD),U,TMOV)+1
+33 SET ORDER=$PIECE(^TMP($JOB,"ECXWARD",WARD),U,1)
SET DIV=$PIECE(^(WARD),U,3)
SET $PIECE(GTOT(DIV),U,TMOV)=$PIECE(GTOT(DIV),U,TMOV)+1
+34 SET SORD=ORDER-.01
SET SORD=$ORDER(STOT(DIV,SORD))
IF +SORD
SET $PIECE(STOT(DIV,SORD),U,TMOV)=$PIECE(STOT(DIV,SORD),U,TMOV)+1
+35 SET CNT=CNT+1
IF $DATA(ZTQUEUED)
IF (CNT>499)
IF '(CNT#500)
IF $$S^%ZTLOAD
SET QQFLG=1
SET ZTSTOP=1
KILL ZTREQ
End DoDot:2
End DoDot:1
if QQFLG
QUIT
+36 ;after all the extract records are processed, set totals into ^tmp($j,"ecxorder"
+37 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET ZTSTOP=1
KILL ZTREQ
QUIT
+38 SET W=""
FOR
SET W=$ORDER(^TMP($JOB,"TL",W))
if W=""
QUIT
SET TL(W)=^(W)
Begin DoDot:1
+39 SET ORDER=$PIECE(^TMP($JOB,"ECXWARD",W),U,1)
SET DIV=$PIECE(^(W),U,3)
+40 SET LINETOT=0
FOR JJ=1:1:MOV
SET $PIECE(^TMP($JOB,"ECXORDER",DIV,ORDER),U,JJ+2)=$PIECE(TL(W),U,JJ)
SET LINETOT=LINETOT+$PIECE(TL(W),U,JJ)
+41 KILL TL(W)
+42 ;don't keep inactive wards unless there is movement data
+43 IF ORDER>999990
IF LINETOT=0
KILL ^TMP($JOB,"ECXORDER",DIV,ORDER)
+44 IF $DATA(^TMP($JOB,"ECXORDER",DIV,ORDER,1))
Begin DoDot:2
+45 ;don't do group total on inactive/unordered wards
+46 IF ORDER>999990
KILL ^TMP($JOB,"ECXORDER",DIV,ORDER,1)
QUIT
+47 FOR JJ=1:1:MOV
SET $PIECE(^TMP($JOB,"ECXORDER",DIV,ORDER,1),U,JJ+2)=$PIECE(STOT(DIV,ORDER),U,JJ)
End DoDot:2
End DoDot:1
+48 DO PRINT
+49 ;149
IF $GET(ECXPORT)
QUIT
+50 DO AUDIT^ECXKILL
+51 QUIT
+52 ;
PRINT ;print the movement data by division and ward order
+1 NEW JJ,SS,LN,NM,TNM,PG,QFLG,WRDNM,WRDTOT,GRPNM,GRPTOT,DIVTOT,DATA,DATA1
+2 NEW TYPE,DIC,DA,DR,DIR,DIRUT,DTOUT,DUOUT,W1,W2,ADMDT,IEN,FAC
+3 USE IO
+4 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET ZTSTOP=1
KILL ZTREQ
QUIT
+5 SET (QFLG,PG)=0
SET $PIECE(LN,"-",132)=""
SET DIV=""
+6 FOR
SET DIV=$ORDER(GTOT(DIV))
if DIV=""
QUIT
Begin DoDot:1
+7 FOR TYPE=2,3
SET TNM=$SELECT(TYPE=2:"Transfer",TYPE=3:"Discharge",1:"")
DO HEADER
if QFLG
QUIT
SET MOV=""
SET DIVTOT=0
Begin DoDot:2
+8 ;149 Section added
IF $GET(ECXPORT)
Begin DoDot:3
+9 IF TYPE=2
SET ^TMP($JOB,"ECXPORT",RCNT)="EXTRACT LOG #^DIVISION^WARD <DSS DEPT>^1^2^3^4^13^14^22^23^24^25^26^43^44^45^TRANSFER TOTALS"
SET RCNT=RCNT+1
+10 ;149
IF TYPE=3
SET ^TMP($JOB,"ECXPORT",RCNT)="EXTRACT LOG #^DIVISION^WARD^10^11^12^16^17^21^27^31^32^33^34^35^37^38^41^42^46^47^DISCHARGE TOTALS"
SET RCNT=RCNT+1
End DoDot:3
+11 FOR
SET MOV=$ORDER(^TMP($JOB,"MOV",TYPE,MOV))
if MOV=""
QUIT
SET DIVTOT=DIVTOT+$PIECE(GTOT(DIV),U,MOV)
+12 IF DIVTOT=0
Begin DoDot:3
+13 ;149 Section added
IF $GET(ECXPORT)
Begin DoDot:4
+14 SET ^TMP($JOB,"ECXPORT",RCNT)=ECXEXT_U_$PIECE(ECXDIV(DIV),U,2)_" ("_$PIECE(ECXDIV(DIV),U,3)_")"_U_"No "_TNM_" data extracted for this medical center division"
SET RCNT=RCNT+1
+15 SET ^TMP($JOB,"ECXPORT",RCNT)=$$REPEAT^XLFSTR("*",80)
SET RCNT=RCNT+1
End DoDot:4
QUIT
+16 WRITE !!,"No "_TNM_" data extracted for this medical center division.",!
End DoDot:3
QUIT
+17 SET ORDER=""
FOR
SET ORDER=$ORDER(^TMP($JOB,"ECXORDER",DIV,ORDER))
if ORDER=""
QUIT
Begin DoDot:3
+18 SET DATA=^TMP($JOB,"ECXORDER",DIV,ORDER)
KILL DATA1
IF $DATA(^(ORDER,1))
SET DATA1=^(1)
+19 SET WRDNM=$PIECE(DATA,U,2)
+20 IF TYPE=3
SET WRDNM=$PIECE(WRDNM,"<",1)
SET WRDNM=$EXTRACT(WRDNM,1,14)
+21 IF TYPE=2
Begin DoDot:4
+22 SET W1=$PIECE(WRDNM,"<",1)
SET W2=$PIECE(WRDNM,"<",2)
+23 if W2=""
SET WRDNM=$EXTRACT(W1,1,14)
if W2]""
SET WRDNM=$$LJ^XLFSTR($EXTRACT(W1,1,12),12," ")_" <"_W2
End DoDot:4
+24 if ($Y+3>IOSL)
DO HEADER
if QFLG
QUIT
+25 ;149
if '$GET(ECXPORT)
WRITE !,WRDNM
SET TAB=$SELECT(TYPE=2:20,1:10)
SET LINETOT=0
+26 ;149
IF $GET(ECXPORT)
SET ^TMP($JOB,"ECXPORT",RCNT)=ECXEXT_U_$PIECE(ECXDIV(DIV),U,2)_" ("_$PIECE(ECXDIV(DIV),U,3)_")"_U_$PIECE(DATA,U,2)
+27 FOR
SET MOV=$ORDER(^TMP($JOB,"MOV",TYPE,MOV))
if MOV=""
QUIT
Begin DoDot:4
+28 ;149
SET WRDTOT=$PIECE(DATA,U,2+MOV)
SET TAB=TAB+6
if '$GET(ECXPORT)
WRITE ?TAB,$$RJ^XLFSTR(WRDTOT,5," ")
SET LINETOT=LINETOT+WRDTOT
+29 ;149
IF $GET(ECXPORT)
SET ^TMP($JOB,"ECXPORT",RCNT)=^TMP($JOB,"ECXPORT",RCNT)_U_WRDTOT
End DoDot:4
+30 ;149
IF $GET(ECXPORT)
SET ^TMP($JOB,"ECXPORT",RCNT)=^TMP($JOB,"ECXPORT",RCNT)_U_LINETOT
SET RCNT=RCNT+1
+31 ;149
SET TAB=TAB+8
if '$GET(ECXPORT)
WRITE ?TAB,$$RJ^XLFSTR(LINETOT,5," ")
+32 ;if data1 exists, then this is the end of a ward group so print group totals
+33 IF $GET(DATA1)
Begin DoDot:4
+34 SET GRPNM=$PIECE(DATA1,U,2)
if ($Y+3>IOSL)
DO HEADER
if QFLG
QUIT
+35 ;149
IF '$GET(ECXPORT)
WRITE !,?18,$EXTRACT(LN,1,113)
+36 ;149
IF '$GET(ECXPORT)
if ($Y+3>IOSL)
DO HEADER
if QFLG
QUIT
WRITE !,"Ward group "_GRPNM_" subtotals:",!
+37 ;149
IF $GET(ECXPORT)
SET ^TMP($JOB,"ECXPORT",RCNT)="^"
SET RCNT=RCNT+1
SET ^TMP($JOB,"ECXPORT",RCNT)="^^"_"Ward Group "_GRPNM_$SELECT(TYPE=2:" transfer",1:" discharge")_" subtotals"
+38 if ($Y+3>IOSL)
DO HEADER
if QFLG
QUIT
+39 SET TAB=$SELECT(TYPE=2:20,1:10)
SET LINETOT=0
+40 FOR
SET MOV=$ORDER(^TMP($JOB,"MOV",TYPE,MOV))
if MOV=""
QUIT
Begin DoDot:5
+41 ;149
SET GRPTOT=$PIECE(DATA1,U,2+MOV)
SET TAB=TAB+6
if '$GET(ECXPORT)
WRITE ?TAB,$$RJ^XLFSTR(GRPTOT,5," ")
SET LINETOT=LINETOT+GRPTOT
+42 ;149
IF $GET(ECXPORT)
SET ^TMP($JOB,"ECXPORT",RCNT)=^TMP($JOB,"ECXPORT",RCNT)_U_GRPTOT
End DoDot:5
+43 ;149
IF $GET(ECXPORT)
SET ^TMP($JOB,"ECXPORT",RCNT)=^TMP($JOB,"ECXPORT",RCNT)_U_LINETOT
SET RCNT=RCNT+1
SET ^TMP($JOB,"ECXPORT",RCNT)="^"
SET RCNT=RCNT+1
+44 ;149
SET TAB=TAB+8
if '$GET(ECXPORT)
WRITE ?TAB,$$RJ^XLFSTR(LINETOT,5," ")
+45 if ($Y+3>IOSL)
DO HEADER
if QFLG
QUIT
+46 ;149
IF '$GET(ECXPORT)
WRITE !!
End DoDot:4
if QFLG
QUIT
End DoDot:3
if QFLG
QUIT
+47 if QFLG
QUIT
+48 ;149
IF '$GET(ECXPORT)
if ($Y+3>IOSL)
DO HEADER
if QFLG
QUIT
WRITE !!,"Division "_$PIECE(ECXDIV(DIV),U,2)_" Grand Totals:",!
+49 ;149
IF $GET(ECXPORT)
SET ^TMP($JOB,"ECXPORT",RCNT)="^"
SET RCNT=RCNT+1
SET ^TMP($JOB,"ECXPORT",RCNT)="^"_"Division "_$PIECE(ECXDIV(DIV),U,2)_" Grand Totals^"
+50 if ($Y+3>IOSL)
DO HEADER
if QFLG
QUIT
+51 SET TAB=$SELECT(TYPE=2:20,1:10)
SET LINETOT=0
+52 FOR
SET MOV=$ORDER(^TMP($JOB,"MOV",TYPE,MOV))
if MOV=""
QUIT
Begin DoDot:3
+53 ;149
SET GTOT=$PIECE(GTOT(DIV),U,MOV)
SET TAB=TAB+6
if '$GET(ECXPORT)
WRITE ?TAB,$$RJ^XLFSTR(GTOT,5," ")
SET LINETOT=LINETOT+GTOT
+54 ;149
IF $GET(ECXPORT)
SET ^TMP($JOB,"ECXPORT",RCNT)=^TMP($JOB,"ECXPORT",RCNT)_U_GTOT
End DoDot:3
+55 ;149
IF $GET(ECXPORT)
SET ^TMP($JOB,"ECXPORT",RCNT)=^TMP($JOB,"ECXPORT",RCNT)_U_LINETOT
SET RCNT=RCNT+1
SET ^TMP($JOB,"ECXPORT",RCNT)=$$REPEAT^XLFSTR("*",80)
SET RCNT=RCNT+1
QUIT
+56 SET TAB=TAB+8
WRITE ?TAB,$$RJ^XLFSTR(LINETOT,5," ")
+57 IF $EXTRACT(IOST)'="C"
DO LEGEND
End DoDot:2
if QFLG
QUIT
End DoDot:1
if QFLG
QUIT
+58 ;print patients with missing wards
+59 IF $DATA(^TMP($JOB,"MISWRD"))
Begin DoDot:1
+60 SET DIV="MISWRD"
SET ECXDIV(DIV)="^^^^^*** MISSING WARDS ***^"
SET TYPE=0
+61 DO HEADER
SET WRDTOT=$GET(^TMP($JOB,"MISWRD"))
+62 ;173
IF $GET(ECXPORT)
Begin DoDot:2
+63 ;149,173
SET ^TMP($JOB,"ECXPORT",RCNT)="^"
SET RCNT=RCNT+1
SET ^TMP($JOB,"ECXPORT",RCNT)="^^MISSING WARD"_U_WRDTOT
SET RCNT=RCNT+1
SET ^TMP($JOB,"ECXPORT",RCNT)="^"
SET RCNT=RCNT+1
+64 ;173,174
SET ^TMP($JOB,"ECXPORT",RCNT)="^NOTE: Records are generated in the extract for ASIH Other Facility movement types."
SET RCNT=RCNT+1
+65 ;173,174
SET ^TMP($JOB,"ECXPORT",RCNT)="^If present in your facility, this report will display them. Missing wards"
SET RCNT=RCNT+1
+66 ;173,174
SET ^TMP($JOB,"ECXPORT",RCNT)="^for ASIH Other Facility patients REQUIRE NO ACTION because the patient"
SET RCNT=RCNT+1
+67 ;174
SET ^TMP($JOB,"ECXPORT",RCNT)="^is at another facility."
SET RCNT=RCNT+1
+68 ;173
SET ^TMP($JOB,"ECXPORT",RCNT)="^"
SET RCNT=RCNT+1
+69 ;173
SET ^TMP($JOB,"ECXPORT",RCNT)="^NAME^PATIENT DFN^FACILITY^ADMISSION DATE^ASIH OTHER FACILITY MOVEMENT"
SET RCNT=RCNT+1
End DoDot:2
+70 ;149,173
IF '$GET(ECXPORT)
Begin DoDot:2
+71 ;149,173
WRITE !,?5,"MISSING WARD",?45,$$RJ^XLFSTR(WRDTOT,5," "),!!
+72 ;173,174
WRITE "NOTE: Records are generated in the extract for ASIH Other Facility movement types. If present in your facility, this report will",!,"display them. Missing Wards for ASIH Other Facility"
+73 ;174
WRITE " patients REQUIRE NO ACTION because the patient is at another facility.",!
End DoDot:2
+74 ;149
if '$GET(ECXPORT)
DO HEAD
SET IEN=""
+75 FOR
SET IEN=$ORDER(^TMP($JOB,"MISWRD",IEN))
if 'IEN
QUIT
Begin DoDot:2
+76 SET DATA=$GET(^ECX(727.808,IEN,0))
SET ADMDT=$PIECE(DATA,U,11)
if DATA=""
QUIT
+77 ;173
SET FAC=$PIECE(DATA,U,4)
if FAC'=""
SET FAC=$$GET1^DIQ(40.8,FAC,.01,"E")
+78 ;173
IF $GET(ECXPORT)
Begin DoDot:3
+79 ;149,173
SET ^TMP($JOB,"ECXPORT",RCNT)="^"_$PIECE(DATA,U,7)_U_$PIECE(DATA,U,5)_U_FAC_U_$EXTRACT(ADMDT,5,6)_"/"_$EXTRACT(ADMDT,7,8)_"/"_$EXTRACT(ADMDT,1,4)_" "_$EXTRACT($PIECE(DATA,U,22),1,2)_":"_$EXTRACT($PIECE(DATA,U,22),3,4)_U_.
..
... $SELECT($PIECE(DATA,U,8)="A":"YES",1:"NO")
SET RCNT=RCNT+1
End DoDot:3
QUIT
+80 WRITE !?2,$PIECE(DATA,U,7),?8,$PIECE(DATA,U,5),?25,$EXTRACT(FAC,1,14),?45
+81 WRITE $EXTRACT(ADMDT,5,6)_"/"_$EXTRACT(ADMDT,7,8)_"/"_$EXTRACT(ADMDT,1,4)," "
+82 WRITE $EXTRACT($PIECE(DATA,U,22),1,2)_":"_$EXTRACT($PIECE(DATA,U,22),3,4)
+83 ;173 Is this an ASIH mvmt
WRITE ?65,$SELECT($PIECE(DATA,U,8)="A":"YES",1:"NO")
+84 ;149
IF '$GET(ECXPORT)
if ($Y+3>IOSL)
DO HEADER
DO HEAD
if QFLG
QUIT
End DoDot:2
IF QFLG
QUIT
End DoDot:1
+85 ;149
IF $GET(ECXPORT)
QUIT
+86 IF $EXTRACT(IOST)'="C"
Begin DoDot:1
+87 WRITE @IOF
SET PG=PG+1
+88 WRITE !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report"
+89 WRITE !,"DSS Extract Log #: "_ECXEXT
+90 WRITE !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END")
+91 WRITE !,"Report Run Date/Time: "_ECXRUN,?120,"Page: ",PG
+92 WRITE !!,LN,!!
+93 SET DIC="^ECX(727.1,"
SET DA=ECXARRAY("DEF")
SET DR="1"
DO EN^DIQ
End DoDot:1
+94 IF $EXTRACT(IOST)="C"
IF 'QFLG
Begin DoDot:1
+95 SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
+96 SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
End DoDot:1
+97 QUIT
+98 ;
HEAD ;header for missing wards
+1 ;173
WRITE !,?2,"NAME",?8,"PATIENT DFN",?25,"FACILITY",?45,"ADMISSION DATE",?65,"ASIH OTHER FACILITY"
+2 ;173
WRITE !,?2,"====",?8,"===========",?25,"========",?45,"==============",?65,"==================="
+3 QUIT
+4 ;
+1 NEW JJ,SS,TAB,DSSID
+2 ;149
IF $GET(QFLG)!($GET(ECXPORT))
QUIT
+3 IF $EXTRACT(IOST)="C"
Begin DoDot:1
+4 SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
+5 IF PG>0
SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
if 'Y
SET QFLG=1
End DoDot:1
+6 if QFLG
QUIT
+7 SET DSSID=$PIECE(ECXDIV(DIV),U,6)
+8 if $Y!($EXTRACT(IOST)="C")
WRITE @IOF
SET PG=PG+1
+9 WRITE !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report"
+10 WRITE !,"DSS Extract Log #: "_ECXEXT
+11 WRITE !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END")
+12 WRITE !,"Report Run Date/Time: "_ECXRUN
+13 IF DSSID=""
WRITE !,"Medical Center Division: "_$PIECE(ECXDIV(DIV),U,2)_" ("_$PIECE(ECXDIV(DIV),U,3)_")",?120,"Page: "_PG
+14 IF DSSID]""
WRITE !,"Medical Center Division: "_$PIECE(ECXDIV(DIV),U,2)_" ("_$PIECE(ECXDIV(DIV),U,3)_")"_" <"_DSSID_">",?120,"Page: "_PG
+15 SET TAB=$SELECT(TYPE=2:28,1:20)
WRITE !!
+16 IF TYPE=2
WRITE "Ward <DSS Dept.>",?TAB,"MAS Movement ("_TNM_") Types",!
+17 IF TYPE=3
WRITE "Ward",?TAB,"MAS Movement ("_TNM_") Types",!
+18 SET MOV=""
SET TAB=$SELECT(TYPE=0:40,TYPE=2:20,1:10)
+19 FOR
SET MOV=$ORDER(^TMP($JOB,"MOV",TYPE,MOV))
if MOV=""
QUIT
SET TAB=TAB+6
WRITE ?TAB,$$RJ^XLFSTR(MOV,5," ")
+20 SET TAB=TAB+8
WRITE ?TAB,$$RJ^XLFSTR("Total",5," ")
+21 WRITE !,LN,!
+22 QUIT
+23 ;
LEGEND ;print legend for each report type
+1 NEW MOV,MOVNM
+2 if ($Y+10>IOSL)
DO HEADER
+3 WRITE !!,TNM_" Movements Legend --"
+4 SET MOV=""
FOR
SET MOV=$ORDER(^TMP($JOB,"MOV",TYPE,MOV))
if MOV=""
QUIT
Begin DoDot:1
+5 SET MOVNM=^TMP($JOB,"MOV",TYPE,MOV)
WRITE !,MOV,?4,"= ",$EXTRACT(MOVNM,1,32)
+6 SET MOV=$ORDER(^TMP($JOB,"MOV",TYPE,MOV))
if MOV=""
QUIT
SET MOVNM=^(MOV)
WRITE ?41,MOV,?44,"= ",$EXTRACT(MOVNM,1,32)
+7 SET MOV=$ORDER(^TMP($JOB,"MOV",TYPE,MOV))
if MOV=""
QUIT
SET MOVNM=^(MOV)
WRITE ?81,MOV,?84,"= ",$EXTRACT(MOVNM,1,32)
End DoDot:1
if MOV=""
QUIT
+8 QUIT
