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 ---[H[J[2J[HECXWRD 6807 printed Nov 22, 2024@17:04:39 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
