ECXWRD.m

ECXWRD ;BIR/CML,ALB/JAP  Print Active Wards for Fiscal Year ;11/8/17  14:59

 ;;3.0;DSS EXTRACTS;**2,8,127,149,166,169,181,184**;Dec 22, 1997;Build 124

 ;

 ; Reference to ^DG(40.8) in ICR #417

 ; Reference to ^DIC(42) in ICR #1848

 ;

EN ;entry point from option

 N DATE,YR,MON,FY,POP,ZTSK,ECXPORT,CNT ;149

 D NOW^%DTC S DATE=$$FMTE^XLFDT(%,"5D"),YR=+$P(DATE,"/",3),MON=+$P(DATE,"/",1),FY=$S(MON<10:YR,1:YR+1)

 W !!,"This option prints a list of all wards that were active at any time" ;184 Removed MAS/HAS

 W !,"during FY",FY,".  The list is sorted by Medical Center Division and displays"

 W !,"the pointer to the Hospital Location file (#44) and DSS Department data"

 W !,"if available."

 S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1  ;149

 I ECXPORT D  Q  ;149 Section added

 .K ^TMP($J)

 .S ^TMP($J,"ECXPORT",0)="Expected Divisions with Active Ward/s: " ;181 - Add header to export format

 .S ^TMP($J,"ECXPORT",1)="DIVISION NUMBER^DIVISION^WARD^DSS DEPT^POINTER TO FILE 44^WARD SERVICE^WARD SPECIALTY",CNT=2 ;181 -Add DIVISION Number 

 .D START

 .D EXPDISP^ECXUTL1

 .K ^TMP($J),^TMP("ECXWRD",$J)

 W !!,"This report requires a print width of 132 characters.",!!

 S ECXPGM="START^ECXWRD",ECXDESC="DSS-Print Active Wards for Fiscal Year",ECXSAVE("FY")=""

 W ! D DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE)

 I ECXSAVE("POP")=1 D  Q

 .W !,"No device selected... try again later.!!"

 I ECXSAVE("ZTSK")=0 U IO D START^ECXWRD

 I IO'=IO(0) D ^%ZISC

 D HOME^%ZIS

 K ECXSAVE,ECXPGM,ECXDESC

 K ECXDIVN,ECFYB,ECFYE,ECXWD,ECXWDN,ECXDEPT,ECXDESC,FY,^TMP("ECXWRD",$J)

 Q

START ;

 N QFLG,%,%H,%I,JJ,SS,HDT,DATA,ECXFY,EC,DR,DIQ,DA,DIC,ECX,PG,LN,Y ;149 adding vars to new line

 N ECXDIV,ECXINST,ECXSTA,ECXDIVNO,ECXHDR,ECXFACN,ECXOFAC ;181 

 K ^TMP("ECXWRD",$J)

 S ECXFY=FY-1700

 S ECFYB=ECXFY-1_"1000",ECFYE=ECXFY_"1001"

 ;gather data

 S ECXWD=0,ECXHDR="" ;181 - Added ECXHDR

 S ECXWD=0

 F  S ECXWD=$O(^DIC(42,ECXWD)) Q:'ECXWD  I $D(^DIC(42,ECXWD,0))  D

 .S EC=^DIC(42,ECXWD,0) D CHK Q:X=1

 .S DR=".01;.03;.015;.017;44",DIQ(0)="IE",DIQ="ECX",DA=ECXWD,DIC="^DIC(42," K ECX D EN^DIQ1

 .S ECXWDN=$G(ECX(42,ECXWD,.01,"E"))

 .;181 - Begins

 .S ECXDIVNO=$G(ECX(42,ECXWD,.015,"I")) ;181 - Get DIV ien

 .S ECXDIVN=$G(ECX(42,ECXWD,.015,"E")) S:ECXDIVN="" ECXDIVN="UNKNOWN"

 .S ECXFACN=""

 .I ECXDIVNO'="" D

 ..S DIC="^DG(40.8,",DR="1",DIQ(0)="I",DIQ="ECXDIV",DA=ECXDIVNO K ECXDIV D EN^DIQ1

 ..S ECXFACN=ECXDIV(40.8,ECXDIVNO,1,"I")

 .S ECXDIVN=ECXDIVN_"  -  "_ECXFACN ;Facility Number of the Medical Center Division

 .;181 - Ends

 .S ^TMP("ECXWRD",$J,ECXDIVN,ECXWDN)=$G(ECX(42,ECXWD,44,"I"))_U_$G(ECX(42,ECXWD,.03,"E"))_U_$G(ECX(42,ECXWD,.017,"E"))_U

 .I ECXFACN'="" S ECXHDR(ECXFACN)="" ;181 

 .I $D(^ECX(727.4,ECXWD)) D

 ..S ECXDEPT=$P(^ECX(727.4,ECXWD,0),U,2) Q:ECXDEPT=""

 ..D REVERSE^ECXDSSD(ECXDEPT,.ECXDESC)

 ..S ^TMP("ECXWRD",$J,ECXDIVN,ECXWDN)=^TMP("ECXWRD",$J,ECXDIVN,ECXWDN)_ECXDEPT_U_ECXDESC

 D GETOFAC(.ECXHDR,.ECXOFAC) ; 181 - Get other Facility Number contains 9A,"B" or "P"

 S (ECXHDR,ECXSTA,ECXFACN)="" ;181

 F  S ECXFACN=$O(ECXHDR(ECXFACN)) Q:ECXFACN=""  S ECXHDR=ECXHDR_ECXFACN_"," ;181

 S ECXHDR=ECXHDR_ECXOFAC ;181

 ;print the report

 S (PG,QFLG)=0,$P(LN,"-",130)="" D NOW^%DTC S Y=$E(%,1,12) X ^DD("DD") S HDT=Y

 I '$G(ECXPORT) D HDR ;149

 I '$G(ECXPORT) I '$D(^TMP("ECXWRD",$J)) W !!,"NO DATA FOUND FOR THIS REPORT" Q  ;149

 I $G(ECXPORT) S ^TMP($J,"ECXPORT",0)=^TMP($J,"ECXPORT",0)_ECXHDR  ;181

 S ECXDIVN=""

 F  S ECXDIVN=$O(^TMP("ECXWRD",$J,ECXDIVN)) Q:ECXDIVN=""  Q:QFLG  D

 .I '$G(ECXPORT) D:$Y+4>IOSL HDR Q:QFLG  ;149

 .W:'$G(ECXPORT) !!,"DIVISION: ",ECXDIVN S ECXWDN="" D  ;149 

 ..F  S ECXWDN=$O(^TMP("ECXWRD",$J,ECXDIVN,ECXWDN)) Q:ECXWDN=""  Q:QFLG  D

 ...S DATA=^TMP("ECXWRD",$J,ECXDIVN,ECXWDN),ECXDEPT=$P(DATA,U,4)

 ...I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)=$P(ECXDIVN,"  -  ",2)_U_$P(ECXDIVN,"  -  ")_U_ECXWDN_U_ECXDEPT_U_$P(DATA,U,1,3),CNT=CNT+1 Q  ;149,181 - Add Station Number as the first column

 ...D:$Y+4>IOSL HDR Q:QFLG  W !?5,$E(ECXWDN,1,20),?30,ECXDEPT,?45,$P(DATA,U,1),?60,$E($P(DATA,U,2),1,18),?80,$P(DATA,U,3)

 ...Q:ECXDEPT=""

 ...I '$G(ECXPORT) D:$Y+4>IOSL HDR Q:QFLG  ;149

 ...;W !?30,"[Svc: "_$E($P(DATA,U,5),1,20)_"   "_"Prod. Unit: "_$E($P(DATA,U,6),1,40)_"   "_"Div: "_$P(DATA,U,7)_"]",!

 I '$G(ECXPORT) I $E(IOST)="C"&('QFLG) S DIR(0)="E" D  D ^DIR K DIR ;149

 .S SS=22-$Y F JJ=1:1:SS W !

 I '$G(ECXPORT) W:$E(IOST)'="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" ;149

 K ECXDIVN,ECFYB,ECFYE,ECXWD,ECXWDN,ECXDEPT,ECXDESC,FY,^TMP("ECXWRD",$J)

 Q

 ;

CHK ;has this ward been active?

 ; output      

 ; X = 1 if inactive (out-of-service), 0 otherwise

 ;

 N ECX,ECY

 N DR,DIQ,DIC,ECXWARD ;181

 S X=1 Q:'$D(ECXWD)  S ECY=ECFYB

 S DR=400,DA=ECXWD,DIQ="ECXWARD",DIC="^DIC(42," K ECXWARD D EN^DIQ1 ;181

 I $G(ECXWARD(42,ECXWD,400))="" S X=1 Q  ;181

 I '$O(^DIC(42,ECXWD,"OOS",0)) S X=0 Q

 S ECX=+$O(^DIC(42,ECXWD,"OOS","AINV",9999998.9-ECY)),ECX=$S($D(^DIC(42,ECXWD,"OOS",+$O(^(+ECX,0)),0)):^(0),1:"")

 I '$P(ECX,U,6) S X=0 Q

 I $P(ECX,U,6),'$P(ECX,U,4) S X=1 Q

 I $P(ECX,U,6),$P(ECX,U,4)<ECFYE S X=0 Q

 S X=1

 Q

 ;

HDR ;header and page control

 I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W !

 I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q

 S PG=PG+1 W:$Y!($E(IOST)="C") @IOF W !,"Active Wards for FY",FY,!,"Printed on ",HDT,! ;181 - Update the header

 W !,"Expected Divisions with Active Ward/s: ",ECXHDR,! ;181 

 W !?30,"DSS",?45,"Pointer",?60,"Ward",?80,"Ward"

 W !?5,"WARD",?30,"Department",?45,"to File #44",?60,"Service",?80,"Specialty"

 W !,LN

 Q

 ;

GETSTAT(DIVNUM,STATNO,FACNUM) ; 181 - Added the following sections

 ;Get Station number from the Institution file #4

 ;Get Facility Number from Medical Division file #40.8

 N DIQ,DR,DA,DIC,INST,ECX

 S DIC="^DG(40.8,",DR="1;.07",DIQ(0)="I",DIQ="ECX",DA=DIVNUM K ECX D EN^DIQ1

 S FACNUM=ECX(40.8,DIVNUM,1,"I")

 K DIQ

 S DIC=4,DR="99",DIQ(0)="I",DIQ="ECX",DA=ECX(40.8,DIVNUM,.07,"I") K ECX D EN^DIQ1

 S STATNO=$G(ECX(4,DA,99,"I"))

 Q

GETOFAC(HDR,OFAC) ;181

 ;Get Facility Number which contains "9A","B" or "P" from Medical Division file #40.8

 N DIC,DIVNUM,ECX,FACNUM

 N DIC,ECXDIV,ECXFAC,ECX,TMPFAC

 S ECXDIV=0,OFAC=""

 F  S ECXDIV=$O(^DG(40.8,ECXDIV)) Q:'ECXDIV  D

 .S DIC="^DG(40.8,",DR="1;.07",DIQ(0)="I",DIQ="ECX",DA=ECXDIV K ECX D EN^DIQ1

 .S ECXFAC=$G(ECX(40.8,ECXDIV,1,"I"))

 .S TMPFAC=$S($E(ECXFAC,4,5)="9A":ECXFAC,($E(ECXFAC,4)="B"):ECXFAC,($E(ECXFAC,4)="P"):ECXFAC,1:"")

 .I TMPFAC="" Q

 .S ECXINST=$G(ECX(40.8,ECXDIV,.07,"I"))

 .I ECXINST="" Q

 .K DIQ

 .S DIC=4,DR="101",DIQ(0)="I",DIQ="ECX",DA=ECXINST K ECX D EN^DIQ1

 .I $G(ECX(4,ECXINST,101,"I")) Q  ;Medical Division points to Inactive Institution

 .I '$D(HDR(ECXFAC)) S OFAC=OFAC_TMPFAC_","

 S OFAC=$E(OFAC,1,$L(OFAC)-1)

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---ECXWRD   6807     printed  Mar 13, 2025@20:59:10                                                                                                                                                                                                      Page 2

ECXWRD    ;BIR/CML,ALB/JAP  Print Active Wards for Fiscal Year ;11/8/17  14:59

 +1       ;;3.0;DSS EXTRACTS;**2,8,127,149,166,169,181,184**;Dec 22, 1997;Build 124

 +2       ;

 +3       ; Reference to ^DG(40.8) in ICR #417

 +4       ; Reference to ^DIC(42) in ICR #1848

 +5       ;

EN        ;entry point from option

 +1       ;149

           NEW DATE,YR,MON,FY,POP,ZTSK,ECXPORT,CNT

 +2        DO NOW^%DTC

           SET DATE=$$FMTE^XLFDT(%,"5D")

           SET YR=+$PIECE(DATE,"/",3)

           SET MON=+$PIECE(DATE,"/",1)

           SET FY=$SELECT(MON<10:YR,1:YR+1)

 +3       ;184 Removed MAS/HAS

           WRITE !!,"This option prints a list of all wards that were active at any time"

 +4        WRITE !,"during FY",FY,".  The list is sorted by Medical Center Division and displays"

 +5        WRITE !,"the pointer to the Hospital Location file (#44) and DSS Department data"

 +6        WRITE !,"if available."

 +7       ;149

           SET ECXPORT=$$EXPORT^ECXUTL1

           if ECXPORT=-1

               QUIT 

 +8       ;149 Section added

           IF ECXPORT

               Begin DoDot:1

 +9                KILL ^TMP($JOB)

 +10      ;181 - Add header to export format

                   SET ^TMP($JOB,"ECXPORT",0)="Expected Divisions with Active Ward/s: "

 +11      ;181 -Add DIVISION Number 

                   SET ^TMP($JOB,"ECXPORT",1)="DIVISION NUMBER^DIVISION^WARD^DSS DEPT^POINTER TO FILE 44^WARD SERVICE^WARD SPECIALTY"

                   SET CNT=2

 +12               DO START

 +13               DO EXPDISP^ECXUTL1

 +14               KILL ^TMP($JOB),^TMP("ECXWRD",$JOB)

               End DoDot:1

               QUIT 

 +15       WRITE !!,"This report requires a print width of 132 characters.",!!

 +16       SET ECXPGM="START^ECXWRD"

           SET ECXDESC="DSS-Print Active Wards for Fiscal Year"

           SET ECXSAVE("FY")=""

 +17       WRITE !

           DO DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE)

 +18       IF ECXSAVE("POP")=1

               Begin DoDot:1

 +19               WRITE !,"No device selected... try again later.!!"

               End DoDot:1

               QUIT 

 +20       IF ECXSAVE("ZTSK")=0

               USE IO

               DO START^ECXWRD

 +21       IF IO'=IO(0)

               DO ^%ZISC

 +22       DO HOME^%ZIS

 +23       KILL ECXSAVE,ECXPGM,ECXDESC

 +24       KILL ECXDIVN,ECFYB,ECFYE,ECXWD,ECXWDN,ECXDEPT,ECXDESC,FY,^TMP("ECXWRD",$JOB)

 +25       QUIT 

START     ;

 +1       ;149 adding vars to new line

           NEW QFLG,%,%H,%I,JJ,SS,HDT,DATA,ECXFY,EC,DR,DIQ,DA,DIC,ECX,PG,LN,Y

 +2       ;181 

           NEW ECXDIV,ECXINST,ECXSTA,ECXDIVNO,ECXHDR,ECXFACN,ECXOFAC

 +3        KILL ^TMP("ECXWRD",$JOB)

 +4        SET ECXFY=FY-1700

 +5        SET ECFYB=ECXFY-1_"1000"

           SET ECFYE=ECXFY_"1001"

 +6       ;gather data

 +7       ;181 - Added ECXHDR

           SET ECXWD=0

           SET ECXHDR=""

 +8        SET ECXWD=0

 +9        FOR 

               SET ECXWD=$ORDER(^DIC(42,ECXWD))

               if 'ECXWD

                   QUIT 

               IF $DATA(^DIC(42,ECXWD,0))

                   Begin DoDot:1

 +10                   SET EC=^DIC(42,ECXWD,0)

                       DO CHK

                       if X=1

                           QUIT 

 +11                   SET DR=".01;.03;.015;.017;44"

                       SET DIQ(0)="IE"

                       SET DIQ="ECX"

                       SET DA=ECXWD

                       SET DIC="^DIC(42,"

                       KILL ECX

                       DO EN^DIQ1

 +12                   SET ECXWDN=$GET(ECX(42,ECXWD,.01,"E"))

 +13      ;181 - Begins

 +14      ;181 - Get DIV ien

                       SET ECXDIVNO=$GET(ECX(42,ECXWD,.015,"I"))

 +15                   SET ECXDIVN=$GET(ECX(42,ECXWD,.015,"E"))

                       if ECXDIVN=""

                           SET ECXDIVN="UNKNOWN"

 +16                   SET ECXFACN=""

 +17                   IF ECXDIVNO'=""

                           Begin DoDot:2

 +18                           SET DIC="^DG(40.8,"

                               SET DR="1"

                               SET DIQ(0)="I"

                               SET DIQ="ECXDIV"

                               SET DA=ECXDIVNO

                               KILL ECXDIV

                               DO EN^DIQ1

 +19                           SET ECXFACN=ECXDIV(40.8,ECXDIVNO,1,"I")

                           End DoDot:2

 +20      ;Facility Number of the Medical Center Division

                       SET ECXDIVN=ECXDIVN_"  -  "_ECXFACN

 +21      ;181 - Ends

 +22                   SET ^TMP("ECXWRD",$JOB,ECXDIVN,ECXWDN)=$GET(ECX(42,ECXWD,44,"I"))_U_$GET(ECX(42,ECXWD,.03,"E"))_U_$GET(ECX(42,ECXWD,.017,"E"))_U

 +23      ;181 

                       IF ECXFACN'=""

                           SET ECXHDR(ECXFACN)=""

 +24                   IF $DATA(^ECX(727.4,ECXWD))

                           Begin DoDot:2

 +25                           SET ECXDEPT=$PIECE(^ECX(727.4,ECXWD,0),U,2)

                               if ECXDEPT=""

                                   QUIT 

 +26                           DO REVERSE^ECXDSSD(ECXDEPT,.ECXDESC)

 +27                           SET ^TMP("ECXWRD",$JOB,ECXDIVN,ECXWDN)=^TMP("ECXWRD",$JOB,ECXDIVN,ECXWDN)_ECXDEPT_U_ECXDESC

                           End DoDot:2

                   End DoDot:1

 +28      ; 181 - Get other Facility Number contains 9A,"B" or "P"

           DO GETOFAC(.ECXHDR,.ECXOFAC)

 +29      ;181

           SET (ECXHDR,ECXSTA,ECXFACN)=""

 +30      ;181

           FOR 

               SET ECXFACN=$ORDER(ECXHDR(ECXFACN))

               if ECXFACN=""

                   QUIT 

               SET ECXHDR=ECXHDR_ECXFACN_","

 +31      ;181

           SET ECXHDR=ECXHDR_ECXOFAC

 +32      ;print the report

 +33       SET (PG,QFLG)=0

           SET $PIECE(LN,"-",130)=""

           DO NOW^%DTC

           SET Y=$EXTRACT(%,1,12)

           XECUTE ^DD("DD")

           SET HDT=Y

 +34      ;149

           IF '$GET(ECXPORT)

               DO HDR

 +35      ;149

           IF '$GET(ECXPORT)

               IF '$DATA(^TMP("ECXWRD",$JOB))

                   WRITE !!,"NO DATA FOUND FOR THIS REPORT"

                   QUIT 

 +36      ;181

           IF $GET(ECXPORT)

               SET ^TMP($JOB,"ECXPORT",0)=^TMP($JOB,"ECXPORT",0)_ECXHDR

 +37       SET ECXDIVN=""

 +38       FOR 

               SET ECXDIVN=$ORDER(^TMP("ECXWRD",$JOB,ECXDIVN))

               if ECXDIVN=""

                   QUIT 

               if QFLG

                   QUIT 

               Begin DoDot:1

 +39      ;149

                   IF '$GET(ECXPORT)

                       if $Y+4>IOSL

                           DO HDR

                       if QFLG

                           QUIT 

 +40      ;149 

                   if '$GET(ECXPORT)

                       WRITE !!,"DIVISION: ",ECXDIVN

                   SET ECXWDN=""

                   Begin DoDot:2

 +41                   FOR 

                           SET ECXWDN=$ORDER(^TMP("ECXWRD",$JOB,ECXDIVN,ECXWDN))

                           if ECXWDN=""

                               QUIT 

                           if QFLG

                               QUIT 

                           Begin DoDot:3

 +42                           SET DATA=^TMP("ECXWRD",$JOB,ECXDIVN,ECXWDN)

                               SET ECXDEPT=$PIECE(DATA,U,4)

 +43      ;149,181 - Add Station Number as the first column

                               IF $GET(ECXPORT)

                                   SET ^TMP($JOB,"ECXPORT",CNT)=$PIECE(ECXDIVN,"  -  ",2)_U_$PIECE(ECXDIVN,"  -  ")_U_ECXWDN_U_ECXDEPT_U_$PIECE(DATA,U,1,3)

                                   SET CNT=CNT+1

                                   QUIT 

 +44                           if $Y+4>IOSL

                                   DO HDR

                               if QFLG

                                   QUIT 

                               WRITE !?5,$EXTRACT(ECXWDN,1,20),?30,ECXDEPT,?45,$PIECE(DATA,U,1),?60,$EXTRACT($PIECE(DATA,U,2),1,18),?80,$PIECE(DATA,U,3)

 +45                           if ECXDEPT=""

                                   QUIT 

 +46      ;149

                               IF '$GET(ECXPORT)

                                   if $Y+4>IOSL

                                       DO HDR

                                   if QFLG

                                       QUIT 

 +47      ;W !?30,"[Svc: "_$E($P(DATA,U,5),1,20)_"   "_"Prod. Unit: "_$E($P(DATA,U,6),1,40)_"   "_"Div: "_$P(DATA,U,7)_"]",!

                           End DoDot:3

                   End DoDot:2

               End DoDot:1

 +48      ;149

           IF '$GET(ECXPORT)

               IF $EXTRACT(IOST)="C"&('QFLG)

                   SET DIR(0)="E"

                   Begin DoDot:1

 +49                   SET SS=22-$Y

                       FOR JJ=1:1:SS

                           WRITE !

                   End DoDot:1

                   DO ^DIR

                   KILL DIR

 +50      ;149

           IF '$GET(ECXPORT)

               if $EXTRACT(IOST)'="C"

                   WRITE @IOF

               DO ^%ZISC

               if $DATA(ZTQUEUED)

                   SET ZTREQ="@"

 +51       KILL ECXDIVN,ECFYB,ECFYE,ECXWD,ECXWDN,ECXDEPT,ECXDESC,FY,^TMP("ECXWRD",$JOB)

 +52       QUIT 

 +53      ;

CHK       ;has this ward been active?

 +1       ; output      

 +2       ; X = 1 if inactive (out-of-service), 0 otherwise

 +3       ;

 +4        NEW ECX,ECY

 +5       ;181

           NEW DR,DIQ,DIC,ECXWARD

 +6        SET X=1

           if '$DATA(ECXWD)

               QUIT 

           SET ECY=ECFYB

 +7       ;181

           SET DR=400

           SET DA=ECXWD

           SET DIQ="ECXWARD"

           SET DIC="^DIC(42,"

           KILL ECXWARD

           DO EN^DIQ1

 +8       ;181

           IF $GET(ECXWARD(42,ECXWD,400))=""

               SET X=1

               QUIT 

 +9        IF '$ORDER(^DIC(42,ECXWD,"OOS",0))

               SET X=0

               QUIT 

 +10       SET ECX=+$ORDER(^DIC(42,ECXWD,"OOS","AINV",9999998.9-ECY))

           SET ECX=$SELECT($DATA(^DIC(42,ECXWD,"OOS",+$ORDER(^(+ECX,0)),0)):^(0),1:"")

 +11       IF '$PIECE(ECX,U,6)

               SET X=0

               QUIT 

 +12       IF $PIECE(ECX,U,6)

               IF '$PIECE(ECX,U,4)

                   SET X=1

                   QUIT 

 +13       IF $PIECE(ECX,U,6)

               IF $PIECE(ECX,U,4)<ECFYE

                   SET X=0

                   QUIT 

 +14       SET X=1

 +15       QUIT 

 +16      ;

HDR       ;header and page control

 +1        IF $EXTRACT(IOST)="C"

               SET SS=22-$Y

               FOR JJ=1:1:SS

                   WRITE !

 +2        IF $EXTRACT(IOST)="C"

               IF PG>0

                   SET DIR(0)="E"

                   WRITE !

                   DO ^DIR

                   KILL DIR

                   IF 'Y

                       SET QFLG=1

                       QUIT 

 +3       ;181 - Update the header

           SET PG=PG+1

           if $Y!($EXTRACT(IOST)="C")

               WRITE @IOF

           WRITE !,"Active Wards for FY",FY,!,"Printed on ",HDT,!

 +4       ;181 

           WRITE !,"Expected Divisions with Active Ward/s: ",ECXHDR,!

 +5        WRITE !?30,"DSS",?45,"Pointer",?60,"Ward",?80,"Ward"

 +6        WRITE !?5,"WARD",?30,"Department",?45,"to File #44",?60,"Service",?80,"Specialty"

 +7        WRITE !,LN

 +8        QUIT 

 +9       ;

GETSTAT(DIVNUM,STATNO,FACNUM) ; 181 - Added the following sections

 +1       ;Get Station number from the Institution file #4

 +2       ;Get Facility Number from Medical Division file #40.8

 +3        NEW DIQ,DR,DA,DIC,INST,ECX

 +4        SET DIC="^DG(40.8,"

           SET DR="1;.07"

           SET DIQ(0)="I"

           SET DIQ="ECX"

           SET DA=DIVNUM

           KILL ECX

           DO EN^DIQ1

 +5        SET FACNUM=ECX(40.8,DIVNUM,1,"I")

 +6        KILL DIQ

 +7        SET DIC=4

           SET DR="99"

           SET DIQ(0)="I"

           SET DIQ="ECX"

           SET DA=ECX(40.8,DIVNUM,.07,"I")

           KILL ECX

           DO EN^DIQ1

 +8        SET STATNO=$GET(ECX(4,DA,99,"I"))

 +9        QUIT 

GETOFAC(HDR,OFAC) ;181

 +1       ;Get Facility Number which contains "9A","B" or "P" from Medical Division file #40.8

 +2        NEW DIC,DIVNUM,ECX,FACNUM

 +3        NEW DIC,ECXDIV,ECXFAC,ECX,TMPFAC

 +4        SET ECXDIV=0

           SET OFAC=""

 +5        FOR 

               SET ECXDIV=$ORDER(^DG(40.8,ECXDIV))

               if 'ECXDIV

                   QUIT 

               Begin DoDot:1

 +6                SET DIC="^DG(40.8,"

                   SET DR="1;.07"

                   SET DIQ(0)="I"

                   SET DIQ="ECX"

                   SET DA=ECXDIV

                   KILL ECX

                   DO EN^DIQ1

 +7                SET ECXFAC=$GET(ECX(40.8,ECXDIV,1,"I"))

 +8                SET TMPFAC=$SELECT($EXTRACT(ECXFAC,4,5)="9A":ECXFAC,($EXTRACT(ECXFAC,4)="B"):ECXFAC,($EXTRACT(ECXFAC,4)="P"):ECXFAC,1:"")

 +9                IF TMPFAC=""

                       QUIT 

 +10               SET ECXINST=$GET(ECX(40.8,ECXDIV,.07,"I"))

 +11               IF ECXINST=""

                       QUIT 

 +12               KILL DIQ

 +13               SET DIC=4

                   SET DR="101"

                   SET DIQ(0)="I"

                   SET DIQ="ECX"

                   SET DA=ECXINST

                   KILL ECX

                   DO EN^DIQ1

 +14      ;Medical Division points to Inactive Institution

                   IF $GET(ECX(4,ECXINST,101,"I"))

                       QUIT 

 +15               IF '$DATA(HDR(ECXFAC))

                       SET OFAC=OFAC_TMPFAC_","

               End DoDot:1

 +16       SET OFAC=$EXTRACT(OFAC,1,$LENGTH(OFAC)-1)

 +17       QUIT