ECXDVSN1 ;ALB/JAP - Division selection utility (cont.) ; 3/30/07 7:56am
;;3.0;DSS EXTRACTS;**8,105**;Dec 22, 1997;Build 70
;
ECQ(ECXDIV,ECXALL,ECXERR) ;setup division/site information for QSR extract audit report
; input
; ECXDIV = passed by reference array variable (required)
; ECXALL = 0/1 (optional)
; '0' indicates user to select QUASAR site/division;
; '1' indicates 'all' sites/divisions or only one site/division
; exists in file #509850.8; currently only one site is allowed
; to be defined;
; default is '1'
; output
; ECXDIV = data for QUASAR site/division;
; ECXDIV(ien in file #4)=ien in file #509850.8^name^station number
; ECXERR = 0/1
; if input problem, then '1' returned
;
N X,Y,DIC,OUT,ECX,ECXD,ECXIEN
S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1
;currently, only ONE site may be defined in file #509850.8
S:ECXALL=0 ECXALL=1
S ECXERR=0,ECXD=""
;if ecxall=1, then all QUASAR sites/divisions; but there's only one
I ECXALL=1 D
.F S ECXD=$O(^ACK(509850.8,"B",ECXD)) Q:ECXD="" S ECXIEN=$O(^(ECXD,"")) D
..K ECX S DIC="^DIC(4,",DIQ(0)="I",DIQ="ECX",DA=ECXD,DR=".01;99" D EN^DIQ1
..I $D(ECX) S ECXDIV(ECXD)=ECXIEN_U_ECX(4,ECXD,.01,"I")_U_ECX(4,ECXD,99,"I")
..I '$D(ECX) S ECXERR=1
I ECXERR=1 K ECXDIV
I '$D(ECXDIV) S ECXERR=1
Q
;
LAB(ECXACC,ECXALL,ECXERR) ;setup accession area information for LAB extract audit report
; input
; ECXACC = passed by reference array variable (required)
; ECXALL = 0/1 (optional)
; '0' indicates user to select Accession Area(s);
; '1' indicates 'all' Accession Areas are selected
; default is '1'
; output
; ECXACC = data for Accession Area(s);
; ECXACC(ien in file #68)=name^abbreviation
; ECXERR = 0/1
; if input problem, then '1' returned
;
N X,Y,DIC,DIQ,DA,DR,DTOUT,DUOUT,DIRUT,OUT,ECX,ECXA,ECXIEN
S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1
S ECXERR=0,ECXA=""
;if ecxall=1, then all accession areas are selected
I ECXALL=1 D
.;^LRO(68,"B",xxx,ien)=1 indicates a synonym; skip synonyms
.F S ECXA=$O(^LRO(68,"B",ECXA)) Q:ECXA="" S ECXIEN=$O(^(ECXA,"")) D
..Q:^LRO(68,"B",ECXA,ECXIEN)=1
..K ECX S DIC="^LRO(68,",DR=".01;.09",DIQ="ECX",DA=ECXIEN D EN^DIQ1
..Q:'$D(ECX)
..;acc. areas with ZZ in name indicates no longer used
..Q:$E(ECX(68,ECXIEN,.01),1,2)="ZZ"
..S ECXACC(ECXIEN)=ECX(68,ECXIEN,.01)_U_ECX(68,ECXIEN,.09)
;if ecxall=0, user selects some/all acc. areas
;allow user to choose "ZZ"'d acc. area even though it may currently be inactive
I ECXALL=0 S OUT=0 D
.F Q:OUT!ECXERR D
..S DIC="^LRO(68,",DIC(0)="AEMQZ" K X,Y D ^DIC
..I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q
..I Y=-1,X="" S OUT=1 Q
..S ECXACC(+Y)=$P(Y(0),U,1)_U_$P(Y(0),U,11)
I ECXERR=1 K ECXACC
I '$D(ECXACC) S ECXERR=1
Q
;
NUR(ECXDIV,ECXALL,ECXERR) ;setup accession area information for LAB extract audit report
; input
; ECXDIV = passed by reference array variable (required)
; ECXALL = 0/1 (optional)
; '0' indicates user to select nursing location(s)/division(s);
; '1' indicates 'all' nursing locations and medical center divisions
; are selected or facility is non-divisional;
; default is '1'
; output
; ECXDIV = data for nursing location(s) and medical center division(s);
; ECXDIV("D",ien in file #40.8)=ien in file #4^name^station number
; ECXDIV(ien in file #211.4,ien in file #40.8)=ien in file #44
; ECXERR = 0/1
; if input problem, then '1' returned
;
;N X,Y,DIC,DIQ,DA,OUT,ECX,ECXLOC,ECXSC,ECXDIEN,ECXNLIEN,ECXNLNM,ECXPRIME
S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1
S (ECXERR,OUT)=0,ECXSC=""
;get ien in file #40.8 of primary division
S ECXPRIME=$$PRIM^VASITE(DT)
;associate nursing locations with medical center divisions
F S ECXSC=$O(^NURSF(211.4,"B",ECXSC)) Q:ECXSC="" S ECXNLIEN="" F S ECXNLIEN=$O(^NURSF(211.4,"B",ECXSC,ECXNLIEN)) Q:ECXNLIEN="" D
.K ECX
.S ECXDIEN=0,ECXNLNM="",DIC="^SC(",DIQ(0)="I",DIQ="ECX",DA=ECXSC,DR=".01;3.5" D EN^DIQ1
.;if the 15th piece is null or y=-1 then ecxdien=primary division as default
.I $D(ECX) S ECXDIEN=+ECX(44,ECXSC,3.5,"I"),ECXNLNM=ECX(44,ECXSC,.01,"I")
.S:ECXDIEN=0 ECXDIEN=ECXPRIME
.S ECXLOC(ECXDIEN)="",ECXLOC(ECXDIEN,ECXNLIEN)=ECXSC_U_ECXNLNM
;
;if ecxall=1 don't prompt; setup all nursing locations and divisions incl. those w/o division
I ECXALL=1 S ECXDIEN="" D
.F S ECXDIEN=$O(ECXLOC(ECXDIEN)) Q:ECXDIEN="" D
..S DIC="^DG(40.8,",DIC(0)="NXZ",X=ECXDIEN D ^DIC I +Y>0 D
...S ECXDIV("D",ECXDIEN)=$P(Y(0),U,7)_U_$P(Y(0),U,1)_U_$P(Y(0),U,2),ECXNLIEN=""
...F S ECXNLIEN=$O(ECXLOC(ECXDIEN,ECXNLIEN)) Q:ECXNLIEN="" S ECXDIV(ECXNLIEN,ECXDIEN)=ECXLOC(ECXDIEN,ECXNLIEN)
;
;if ecxall=0 let user select division(s)
I ECXALL=0 F Q:OUT!ECXERR D
.S DIC="^DG(40.8,",DIC(0)="AEMQZ",DIC("S")="I $P(^(0),U,3)'=1"
.D ^DIC I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q
.I Y=-1,X="" S OUT=1 Q
.S ECXDIEN=+Y,NM=$P(Y,U,2)
.I '$D(ECXLOC(ECXDIEN)) D Q
..W !!,?5,"Division "_NM_" not associated with Nursing Locations.",!,?5,"Try again...",!
.S ECXDIV("D",ECXDIEN)=$P(Y(0),U,7)_U_$P(Y(0),U,1)_U_$P(Y(0),U,2),ECXNLIEN=""
.F S ECXNLIEN=$O(ECXLOC(ECXDIEN,ECXNLIEN)) Q:ECXNLIEN="" S ECXDIV(ECXNLIEN,ECXDIEN)=ECXLOC(ECXDIEN,ECXNLIEN)
;in case of user up-arrow out or timeout, make sure nothing returned in ecxdiv
I ECXERR=1 K ECXDIV
I '$D(ECXDIV) S ECXERR=1
Q
;
PRE(ECXDIV,ECXALL,ECXERR) ;setup site information for PRE extract audit report
; input
; ECXDIV = passed by reference array variable (required)
; ECXALL = 0/1 (optional)
; '0' indicates user to select Pharmacy site(s);
; '1' indicates 'all' sites are selected
; default is '1'
; output
; ECXDIV = data for Pharmacy site(s);
; ECXDIV(ien in file #59)=IEN in file #59^name^site number^IEN in file #4
; ECXERR = 0/1
; if input problem, then '1' returned
;
N X,Y,DIC,DIQ,DA,OUT,ECXARR,ECXP,ECXIEN,ARRAY
S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1
S ECXERR=0,ECXP="",ARRAY="^TMP($J,""ECXDSS"")"
K @ARRAY
;if ecxall=1, then all pharmacy sites are selected or there's only one
I ECXALL=1 S ECXP="" D
.D PSS^PSO59(,"??","ECXDSS")
.F S ECXP=$O(@ARRAY@("B",ECXP)) Q:ECXP="" S ECXIEN=$O(^(ECXP,0)) Q:'ECXIEN Q:'$D(^(ECXIEN)) D
..S ECXDIV(ECXIEN)=ECXIEN_U_@ARRAY@(ECXIEN,.01)_U_^(.06)_U_^(100)
;if ecxall=0, then user selects pharmacy site(s)
I ECXALL=0 S OUT=0 D
.F Q:OUT!ECXERR D
..N DIC,X,Y,DUOUT,DTOUT
..S DIC="^PS(59,",DIC(0)="AEMQZ"
..D DIC^PSODI(59,.DIC,.X)
..I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q
..I Y=-1,X="" S OUT=1 Q
..D PSS^PSO59(+Y,,"ECXDSS")
..Q:'$D(@ARRAY)
..S ECXDIV(ECXIEN)=ECXIEN_U_@ARRAY@(ECXIEN,.01)_U_^(.06)_U_^(100)
;
I ECXERR=1 K ECXDIV
I '$D(ECXDIV) S ECXERR=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXDVSN1 7054 printed Dec 13, 2024@01:52:32 Page 2
ECXDVSN1 ;ALB/JAP - Division selection utility (cont.) ; 3/30/07 7:56am
+1 ;;3.0;DSS EXTRACTS;**8,105**;Dec 22, 1997;Build 70
+2 ;
ECQ(ECXDIV,ECXALL,ECXERR) ;setup division/site information for QSR extract audit report
+1 ; input
+2 ; ECXDIV = passed by reference array variable (required)
+3 ; ECXALL = 0/1 (optional)
+4 ; '0' indicates user to select QUASAR site/division;
+5 ; '1' indicates 'all' sites/divisions or only one site/division
+6 ; exists in file #509850.8; currently only one site is allowed
+7 ; to be defined;
+8 ; default is '1'
+9 ; output
+10 ; ECXDIV = data for QUASAR site/division;
+11 ; ECXDIV(ien in file #4)=ien in file #509850.8^name^station number
+12 ; ECXERR = 0/1
+13 ; if input problem, then '1' returned
+14 ;
+15 NEW X,Y,DIC,OUT,ECX,ECXD,ECXIEN
+16 if '$DATA(ECXALL)
SET ECXALL=1
if ECXALL=""
SET ECXALL=1
+17 ;currently, only ONE site may be defined in file #509850.8
+18 if ECXALL=0
SET ECXALL=1
+19 SET ECXERR=0
SET ECXD=""
+20 ;if ecxall=1, then all QUASAR sites/divisions; but there's only one
+21 IF ECXALL=1
Begin DoDot:1
+22 FOR
SET ECXD=$ORDER(^ACK(509850.8,"B",ECXD))
if ECXD=""
QUIT
SET ECXIEN=$ORDER(^(ECXD,""))
Begin DoDot:2
+23 KILL ECX
SET DIC="^DIC(4,"
SET DIQ(0)="I"
SET DIQ="ECX"
SET DA=ECXD
SET DR=".01;99"
DO EN^DIQ1
+24 IF $DATA(ECX)
SET ECXDIV(ECXD)=ECXIEN_U_ECX(4,ECXD,.01,"I")_U_ECX(4,ECXD,99,"I")
+25 IF '$DATA(ECX)
SET ECXERR=1
End DoDot:2
End DoDot:1
+26 IF ECXERR=1
KILL ECXDIV
+27 IF '$DATA(ECXDIV)
SET ECXERR=1
+28 QUIT
+29 ;
LAB(ECXACC,ECXALL,ECXERR) ;setup accession area information for LAB extract audit report
+1 ; input
+2 ; ECXACC = passed by reference array variable (required)
+3 ; ECXALL = 0/1 (optional)
+4 ; '0' indicates user to select Accession Area(s);
+5 ; '1' indicates 'all' Accession Areas are selected
+6 ; default is '1'
+7 ; output
+8 ; ECXACC = data for Accession Area(s);
+9 ; ECXACC(ien in file #68)=name^abbreviation
+10 ; ECXERR = 0/1
+11 ; if input problem, then '1' returned
+12 ;
+13 NEW X,Y,DIC,DIQ,DA,DR,DTOUT,DUOUT,DIRUT,OUT,ECX,ECXA,ECXIEN
+14 if '$DATA(ECXALL)
SET ECXALL=1
if ECXALL=""
SET ECXALL=1
+15 SET ECXERR=0
SET ECXA=""
+16 ;if ecxall=1, then all accession areas are selected
+17 IF ECXALL=1
Begin DoDot:1
+18 ;^LRO(68,"B",xxx,ien)=1 indicates a synonym; skip synonyms
+19 FOR
SET ECXA=$ORDER(^LRO(68,"B",ECXA))
if ECXA=""
QUIT
SET ECXIEN=$ORDER(^(ECXA,""))
Begin DoDot:2
+20 if ^LRO(68,"B",ECXA,ECXIEN)=1
QUIT
+21 KILL ECX
SET DIC="^LRO(68,"
SET DR=".01;.09"
SET DIQ="ECX"
SET DA=ECXIEN
DO EN^DIQ1
+22 if '$DATA(ECX)
QUIT
+23 ;acc. areas with ZZ in name indicates no longer used
+24 if $EXTRACT(ECX(68,ECXIEN,.01),1,2)="ZZ"
QUIT
+25 SET ECXACC(ECXIEN)=ECX(68,ECXIEN,.01)_U_ECX(68,ECXIEN,.09)
End DoDot:2
End DoDot:1
+26 ;if ecxall=0, user selects some/all acc. areas
+27 ;allow user to choose "ZZ"'d acc. area even though it may currently be inactive
+28 IF ECXALL=0
SET OUT=0
Begin DoDot:1
+29 FOR
if OUT!ECXERR
QUIT
Begin DoDot:2
+30 SET DIC="^LRO(68,"
SET DIC(0)="AEMQZ"
KILL X,Y
DO ^DIC
+31 IF $GET(DUOUT)!($GET(DTOUT))
SET OUT=1
SET ECXERR=1
QUIT
+32 IF Y=-1
IF X=""
SET OUT=1
QUIT
+33 SET ECXACC(+Y)=$PIECE(Y(0),U,1)_U_$PIECE(Y(0),U,11)
End DoDot:2
End DoDot:1
+34 IF ECXERR=1
KILL ECXACC
+35 IF '$DATA(ECXACC)
SET ECXERR=1
+36 QUIT
+37 ;
NUR(ECXDIV,ECXALL,ECXERR) ;setup accession area information for LAB extract audit report
+1 ; input
+2 ; ECXDIV = passed by reference array variable (required)
+3 ; ECXALL = 0/1 (optional)
+4 ; '0' indicates user to select nursing location(s)/division(s);
+5 ; '1' indicates 'all' nursing locations and medical center divisions
+6 ; are selected or facility is non-divisional;
+7 ; default is '1'
+8 ; output
+9 ; ECXDIV = data for nursing location(s) and medical center division(s);
+10 ; ECXDIV("D",ien in file #40.8)=ien in file #4^name^station number
+11 ; ECXDIV(ien in file #211.4,ien in file #40.8)=ien in file #44
+12 ; ECXERR = 0/1
+13 ; if input problem, then '1' returned
+14 ;
+15 ;N X,Y,DIC,DIQ,DA,OUT,ECX,ECXLOC,ECXSC,ECXDIEN,ECXNLIEN,ECXNLNM,ECXPRIME
+16 if '$DATA(ECXALL)
SET ECXALL=1
if ECXALL=""
SET ECXALL=1
+17 SET (ECXERR,OUT)=0
SET ECXSC=""
+18 ;get ien in file #40.8 of primary division
+19 SET ECXPRIME=$$PRIM^VASITE(DT)
+20 ;associate nursing locations with medical center divisions
+21 FOR
SET ECXSC=$ORDER(^NURSF(211.4,"B",ECXSC))
if ECXSC=""
QUIT
SET ECXNLIEN=""
FOR
SET ECXNLIEN=$ORDER(^NURSF(211.4,"B",ECXSC,ECXNLIEN))
if ECXNLIEN=""
QUIT
Begin DoDot:1
+22 KILL ECX
+23 SET ECXDIEN=0
SET ECXNLNM=""
SET DIC="^SC("
SET DIQ(0)="I"
SET DIQ="ECX"
SET DA=ECXSC
SET DR=".01;3.5"
DO EN^DIQ1
+24 ;if the 15th piece is null or y=-1 then ecxdien=primary division as default
+25 IF $DATA(ECX)
SET ECXDIEN=+ECX(44,ECXSC,3.5,"I")
SET ECXNLNM=ECX(44,ECXSC,.01,"I")
+26 if ECXDIEN=0
SET ECXDIEN=ECXPRIME
+27 SET ECXLOC(ECXDIEN)=""
SET ECXLOC(ECXDIEN,ECXNLIEN)=ECXSC_U_ECXNLNM
End DoDot:1
+28 ;
+29 ;if ecxall=1 don't prompt; setup all nursing locations and divisions incl. those w/o division
+30 IF ECXALL=1
SET ECXDIEN=""
Begin DoDot:1
+31 FOR
SET ECXDIEN=$ORDER(ECXLOC(ECXDIEN))
if ECXDIEN=""
QUIT
Begin DoDot:2
+32 SET DIC="^DG(40.8,"
SET DIC(0)="NXZ"
SET X=ECXDIEN
DO ^DIC
IF +Y>0
Begin DoDot:3
+33 SET ECXDIV("D",ECXDIEN)=$PIECE(Y(0),U,7)_U_$PIECE(Y(0),U,1)_U_$PIECE(Y(0),U,2)
SET ECXNLIEN=""
+34 FOR
SET ECXNLIEN=$ORDER(ECXLOC(ECXDIEN,ECXNLIEN))
if ECXNLIEN=""
QUIT
SET ECXDIV(ECXNLIEN,ECXDIEN)=ECXLOC(ECXDIEN,ECXNLIEN)
End DoDot:3
End DoDot:2
End DoDot:1
+35 ;
+36 ;if ecxall=0 let user select division(s)
+37 IF ECXALL=0
FOR
if OUT!ECXERR
QUIT
Begin DoDot:1
+38 SET DIC="^DG(40.8,"
SET DIC(0)="AEMQZ"
SET DIC("S")="I $P(^(0),U,3)'=1"
+39 DO ^DIC
IF $GET(DUOUT)!($GET(DTOUT))
SET OUT=1
SET ECXERR=1
QUIT
+40 IF Y=-1
IF X=""
SET OUT=1
QUIT
+41 SET ECXDIEN=+Y
SET NM=$PIECE(Y,U,2)
+42 IF '$DATA(ECXLOC(ECXDIEN))
Begin DoDot:2
+43 WRITE !!,?5,"Division "_NM_" not associated with Nursing Locations.",!,?5,"Try again...",!
End DoDot:2
QUIT
+44 SET ECXDIV("D",ECXDIEN)=$PIECE(Y(0),U,7)_U_$PIECE(Y(0),U,1)_U_$PIECE(Y(0),U,2)
SET ECXNLIEN=""
+45 FOR
SET ECXNLIEN=$ORDER(ECXLOC(ECXDIEN,ECXNLIEN))
if ECXNLIEN=""
QUIT
SET ECXDIV(ECXNLIEN,ECXDIEN)=ECXLOC(ECXDIEN,ECXNLIEN)
End DoDot:1
+46 ;in case of user up-arrow out or timeout, make sure nothing returned in ecxdiv
+47 IF ECXERR=1
KILL ECXDIV
+48 IF '$DATA(ECXDIV)
SET ECXERR=1
+49 QUIT
+50 ;
PRE(ECXDIV,ECXALL,ECXERR) ;setup site information for PRE extract audit report
+1 ; input
+2 ; ECXDIV = passed by reference array variable (required)
+3 ; ECXALL = 0/1 (optional)
+4 ; '0' indicates user to select Pharmacy site(s);
+5 ; '1' indicates 'all' sites are selected
+6 ; default is '1'
+7 ; output
+8 ; ECXDIV = data for Pharmacy site(s);
+9 ; ECXDIV(ien in file #59)=IEN in file #59^name^site number^IEN in file #4
+10 ; ECXERR = 0/1
+11 ; if input problem, then '1' returned
+12 ;
+13 NEW X,Y,DIC,DIQ,DA,OUT,ECXARR,ECXP,ECXIEN,ARRAY
+14 if '$DATA(ECXALL)
SET ECXALL=1
if ECXALL=""
SET ECXALL=1
+15 SET ECXERR=0
SET ECXP=""
SET ARRAY="^TMP($J,""ECXDSS"")"
+16 KILL @ARRAY
+17 ;if ecxall=1, then all pharmacy sites are selected or there's only one
+18 IF ECXALL=1
SET ECXP=""
Begin DoDot:1
+19 DO PSS^PSO59(,"??","ECXDSS")
+20 FOR
SET ECXP=$ORDER(@ARRAY@("B",ECXP))
if ECXP=""
QUIT
SET ECXIEN=$ORDER(^(ECXP,0))
if 'ECXIEN
QUIT
if '$DATA(^(ECXIEN))
QUIT
Begin DoDot:2
+21 SET ECXDIV(ECXIEN)=ECXIEN_U_@ARRAY@(ECXIEN,.01)_U_^(.06)_U_^(100)
End DoDot:2
End DoDot:1
+22 ;if ecxall=0, then user selects pharmacy site(s)
+23 IF ECXALL=0
SET OUT=0
Begin DoDot:1
+24 FOR
if OUT!ECXERR
QUIT
Begin DoDot:2
+25 NEW DIC,X,Y,DUOUT,DTOUT
+26 SET DIC="^PS(59,"
SET DIC(0)="AEMQZ"
+27 DO DIC^PSODI(59,.DIC,.X)
+28 IF $GET(DUOUT)!($GET(DTOUT))
SET OUT=1
SET ECXERR=1
QUIT
+29 IF Y=-1
IF X=""
SET OUT=1
QUIT
+30 DO PSS^PSO59(+Y,,"ECXDSS")
+31 if '$DATA(@ARRAY)
QUIT
+32 SET ECXDIV(ECXIEN)=ECXIEN_U_@ARRAY@(ECXIEN,.01)_U_^(.06)_U_^(100)
End DoDot:2
End DoDot:1
+33 ;
+34 IF ECXERR=1
KILL ECXDIV
+35 IF '$DATA(ECXDIV)
SET ECXERR=1
+36 QUIT
