ECXWRDX ;ALB/MRY - Assign DSS Dept. to Ward ;Mar 2, 2010
;;3.0;DSS EXTRACTS;**8,127**;Dec 22, 1997;Build 36
;
EN ;entry point from menu option
;lookup ward
N DIC,DIR,DTOUT,DUOUT,DIRUT,X,Y,DSSID,OUT,JJ,DA,DR,DIE,SS,DIQ
S DIC(0)="AEMQZ",DIC="^DIC(42," D ^DIC G:$D(DTOUT)!($D(DUOUT))!(+Y<1) EXIT
S ECXWARD=+Y,DSSID=""
S DR=".01;.02;.03;.015;.017",DIQ(0)="IE",DIQ="ECX",DA=ECXWARD,DIC="^DIC(42," K ECX D EN^DIQ1
S ECXWARD=ECXWARD_U_$G(ECX(42,+ECXWARD,.01,"E"))
W !!,"Ward: ",?18,$P(ECXWARD,U,2)
S ECXDIV=$G(ECX(42,+ECXWARD,.015,"I"))
I +ECXDIV>0 D
.S ECXDIV=ECXDIV_U_ECX(42,+ECXWARD,.015,"E")_"/"_$P(^DG(40.8,+ECXDIV,0),U,2)
W !,"Ward Bedsection: ",?18,$G(ECX(42,+ECXWARD,.02,"E"))
W !,"Ward Specialty: ",?18,$G(ECX(42,+ECXWARD,.017,"E"))
W !,"Ward Service: ",?18,$G(ECX(42,+ECXWARD,.03,"E"))
I +ECXDIV>0 W !,"Division: ",?18,$P(ECXDIV,U,2)
;dss id for division is needed to derive dss dept code
I ECXDIV="" D G EN
.W !!,"Cannot proceed with assignment of DSS Department code for ward,"
.W !,"because the ward is not associated with a Medical Center Division."
.W !
.I $E(IOST)="C" D
..S SS=22-$Y F JJ=1:1:SS W !
..S DIR(0)="E" W ! D ^DIR K DIR W !
I '$D(^ECX(727.4,+ECXWARD)) D
.S (X,DINUM)=+ECXWARD,DIC(0)="L",DLAYGO=727.4,DIC="^ECX(727.4,"
.K DD,DO D FILE^DICN K DIC,DINUM,DLAYGO,X,Y
S DIR(0)="727.4,1",DIR("A")="DSS Department for Ward" K X,Y
W !! D ^DIR K DIR Q:$D(DIRUT)
S ECXDEPT=Y
S DA=+ECXWARD,DIE="^ECX(727.4,",DR="1///"_ECXDEPT W !! D ^DIE
K X,Y
Q
EXIT ;common exit point
K ECX,ECXWARD,ECXDEPT,ECXSVC,ECXDIV
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXWRDX 1591 printed Dec 13, 2024@01:54:30 Page 2
ECXWRDX ;ALB/MRY - Assign DSS Dept. to Ward ;Mar 2, 2010
+1 ;;3.0;DSS EXTRACTS;**8,127**;Dec 22, 1997;Build 36
+2 ;
EN ;entry point from menu option
+1 ;lookup ward
+2 NEW DIC,DIR,DTOUT,DUOUT,DIRUT,X,Y,DSSID,OUT,JJ,DA,DR,DIE,SS,DIQ
+3 SET DIC(0)="AEMQZ"
SET DIC="^DIC(42,"
DO ^DIC
if $DATA(DTOUT)!($DATA(DUOUT))!(+Y<1)
GOTO EXIT
+4 SET ECXWARD=+Y
SET DSSID=""
+5 SET DR=".01;.02;.03;.015;.017"
SET DIQ(0)="IE"
SET DIQ="ECX"
SET DA=ECXWARD
SET DIC="^DIC(42,"
KILL ECX
DO EN^DIQ1
+6 SET ECXWARD=ECXWARD_U_$GET(ECX(42,+ECXWARD,.01,"E"))
+7 WRITE !!,"Ward: ",?18,$PIECE(ECXWARD,U,2)
+8 SET ECXDIV=$GET(ECX(42,+ECXWARD,.015,"I"))
+9 IF +ECXDIV>0
Begin DoDot:1
+10 SET ECXDIV=ECXDIV_U_ECX(42,+ECXWARD,.015,"E")_"/"_$PIECE(^DG(40.8,+ECXDIV,0),U,2)
End DoDot:1
+11 WRITE !,"Ward Bedsection: ",?18,$GET(ECX(42,+ECXWARD,.02,"E"))
+12 WRITE !,"Ward Specialty: ",?18,$GET(ECX(42,+ECXWARD,.017,"E"))
+13 WRITE !,"Ward Service: ",?18,$GET(ECX(42,+ECXWARD,.03,"E"))
+14 IF +ECXDIV>0
WRITE !,"Division: ",?18,$PIECE(ECXDIV,U,2)
+15 ;dss id for division is needed to derive dss dept code
+16 IF ECXDIV=""
Begin DoDot:1
+17 WRITE !!,"Cannot proceed with assignment of DSS Department code for ward,"
+18 WRITE !,"because the ward is not associated with a Medical Center Division."
+19 WRITE !
+20 IF $EXTRACT(IOST)="C"
Begin DoDot:2
+21 SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
+22 SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
WRITE !
End DoDot:2
End DoDot:1
GOTO EN
+23 IF '$DATA(^ECX(727.4,+ECXWARD))
Begin DoDot:1
+24 SET (X,DINUM)=+ECXWARD
SET DIC(0)="L"
SET DLAYGO=727.4
SET DIC="^ECX(727.4,"
+25 KILL DD,DO
DO FILE^DICN
KILL DIC,DINUM,DLAYGO,X,Y
End DoDot:1
+26 SET DIR(0)="727.4,1"
SET DIR("A")="DSS Department for Ward"
KILL X,Y
+27 WRITE !!
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
+28 SET ECXDEPT=Y
+29 SET DA=+ECXWARD
SET DIE="^ECX(727.4,"
SET DR="1///"_ECXDEPT
WRITE !!
DO ^DIE
+30 KILL X,Y
+31 QUIT
EXIT ;common exit point
+1 KILL ECX,ECXWARD,ECXDEPT,ECXSVC,ECXDIV
+2 QUIT
