source: WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXWRDX.m@ 1610

Last change on this file since 1610 was 613, checked in by George Lilly, 16 years ago

initial load of WorldVistAEHR
File size: 4.4 KB
Line 
1ECXWRDX ;ALB/JAP - Assign DSS Dept. to Ward ;July 16, 1998
2 ;;3.0;DSS EXTRACTS;**8**;Dec 22, 1997
3 ;
4EN ;entry point from menu option
5 ;lookup ward
6 N DIC,DIR,DTOUT,DUOUT,DIRUT,X,Y,DSSID,OUT
7 S DIC(0)="AEMQZ",DIC="^DIC(42," D ^DIC G:$D(DTOUT)!($D(DUOUT))!(+Y<1) EXIT
8 S ECXWARD=+Y,DSSID=""
9 S DR=".01;.02;.03;.015;.017",DIQ(0)="IE",DIQ="ECX",DA=ECXWARD,DIC="^DIC(42," K ECX D EN^DIQ1
10 S ECXWARD=ECXWARD_U_$G(ECX(42,+ECXWARD,.01,"E"))
11 W !!,"Ward: ",?18,$P(ECXWARD,U,2)
12 S ECXDIV=$G(ECX(42,+ECXWARD,.015,"I"))
13 I +ECXDIV>0 D
14 .;division may not exist in file #727.3, or it may not have a dss id
15 .S DSSID=$P($G(^ECX(727.3,+ECXDIV,0)),U,2) S:DSSID="" DSSID="Not defined"
16 .S ECXDIV=ECXDIV_U_ECX(42,+ECXWARD,.015,"E")_"/"_$P(^DG(40.8,+ECXDIV,0),U,2)_" <"_DSSID_">"
17 W !,"Ward Bedsection: ",?18,$G(ECX(42,+ECXWARD,.02,"E"))
18 W !,"Ward Specialty: ",?18,$G(ECX(42,+ECXWARD,.017,"E"))
19 W !,"Ward Service: ",?18,$G(ECX(42,+ECXWARD,.03,"E"))
20 I +ECXDIV>0 W !,"Division: ",?18,$P(ECXDIV,U,2)
21 ;dss id for division is needed to derive dss dept code
22 I DSSID["Not" D G EN
23 .W !!,"Cannot proceed with assignment of DSS Department code for ward,"
24 .W !,"because the "_ECX(42,+ECXWARD,.015,"E")_" division does not have a DSS Division Identifier."
25 .W !
26 .W !,"Use the Enter/Edit DSS Division Identifier option to associate an"
27 .W !,"identifier with "_ECX(42,+ECXWARD,.015,"E")_"."
28 .I $E(IOST)="C" D
29 ..S SS=22-$Y F JJ=1:1:SS W !
30 ..S DIR(0)="E" W ! D ^DIR K DIR,JJ,SS W !
31 I ECXDIV="" D G EN
32 .W !!,"Cannot proceed with assignment of DSS Department code for ward,"
33 .W !,"because the ward is not associated with a Medical Center Division."
34 .W !
35 .I $E(IOST)="C" D
36 ..S SS=22-$Y F JJ=1:1:SS W !
37 ..S DIR(0)="E" W ! D ^DIR K DIR W !
38 I '$D(ECX(727.4,+ECXWARD)) D
39 .S (X,DINUM)=+ECXWARD,DIC(0)="L",DLAYGO=727.4,DIC="^ECX(727.4,"
40 .K DD,DO D FILE^DICN K DIC,DINUM,DLAYGO,X,Y
41 S DR="1;",DIQ(0)="E",DIQ="ECX",DA=+ECXWARD,DIC="^ECX(727.4," K ECX D EN^DIQ1
42 S ECXDEPT=$G(ECX(727.4,+ECXWARD,1,"E"))
43 S ECXDEPT0=ECXDEPT K X,Y
44 ;if ward has dss dept, then edit
45 I ECXDEPT]"" D
46 .D REVERSE^ECXDSSD(ECXDEPT,.ECXDESC)
47 .W !!,"DSS Department for Ward "_$P(ECXWARD,U,2)
48 .W !?5,"Service ",?20,"<"_$E(ECXDEPT,1)_"> = "_$P(ECXDESC,U,1)
49 .W !?5,"Prod. Unit ",?20,"<"_$E(ECXDEPT,2,3)_"> = "_$P(ECXDESC,U,2)
50 .W !?5,"Division ",?20,"<"_$E(ECXDEPT,4)_"> = "_$P(ECXDESC,U,3)
51 .W !?5,"Suffix ",?22," = "_$E(ECXDEPT,5,7),!!
52 .S DIR(0)="YA",DIR("A")="Do you want edit this DSS Department? ",DIR("B")="YES" K X,Y
53 .D ^DIR K DIR W !!
54 .Q:$D(DIRUT)
55 .I Y=1 D DEPT(ECXWARD,ECXDIV,.ECXDEPT)
56 G:ECXDEPT0]"" EN
57 ;if ward doesn't have dss dept, then enter
58 I ECXDEPT0="" D DEPT(ECXWARD,ECXDIV,.ECXDEPT)
59 G EN
60 ;
61DEPT(ECXWARD,ECXDIV,ECXDEPT) ;allow user to enter/edit dss dept for ward
62 ;division is already known from file #42 (above)
63 ;service is 'nursing' by definition - ien 27 in file #730
64 ; input
65 ; ECXWARD = 1st piece is ien to file #42 & file #727.4; required
66 ; ECXDIV = 1st piece is ien to file $40.8 & file #727.3; required
67 ; output
68 ; ECXDEPT = current dss department code for ward or null
69 N ECXSVC,ECXPUNIT,ECXDESC,ECXSUF,OUT,X,Y,SS,JJ,DIRUT,DTOUT,DUOUT
70 I ECXDEPT="" D
71 .W !,"The medical center division for the ward selected is"
72 .W !,"already known. The service associated with all ward"
73 .W !,"production units is 'Nursing'.",!
74 .W !!,"You must identify the DSS Production Unit for this ward,"
75 .W !,"and a suffix (if needed) to complete the DSS Department code."
76 .I $E(IOST)="C" D
77 ..S SS=22-$Y F JJ=1:1:SS W !
78 ..S DIR(0)="E" W ! D ^DIR K DIR W !
79 I ECXDEPT]"" D
80 .W !,"You may edit the DSS Production Unit and suffix,"
81 F D Q:$D(DIRUT)!(OUT=1)
82 .S ECXDEPT=""
83 .S ECXSVC=27,(ECXPUNIT,ECXSUF)="",OUT=0
84 .S ECXDEPT=$$DERIVE^ECXDSSD(ECXSVC,ECXPUNIT,+ECXDIV,ECXSUF)
85 .;diplay dss dept code to user
86 .I ECXDEPT="" S OUT=1 Q
87 .D REVERSE^ECXDSSD(ECXDEPT,.ECXDESC)
88 .W !!,"DSS Department for Ward "_$P(ECXWARD,U,2)
89 .W !?5,"Service ",?20,"<"_$E(ECXDEPT,1)_"> = "_$P(ECXDESC,U,1)
90 .W !?5,"Prod. Unit ",?20,"<"_$E(ECXDEPT,2,3)_"> = "_$P(ECXDESC,U,2)
91 .W !?5,"Division ",?20,"<"_$E(ECXDEPT,4)_"> = "_$P(ECXDESC,U,3)
92 .W !?5,"Suffix ",?22," = "_$E(ECXDEPT,5,7),!!
93 .S DIR(0)="YA",DIR("A")="Is this ok? ",DIR("B")="YES" K X,Y
94 .D ^DIR K DIR
95 .I $D(DIRUT)!(Y=0) S ECXDEPT="" Q
96 .I Y S OUT=1
97 Q:$D(DIRUT)
98 I ECXDEPT]"" S DIE="^ECX(727.4,",DA=+ECXWARD,DR="1////^S X=ECXDEPT;" D ^DIE
99 W !!
100 Q
101 ;
102EXIT ;common exit point
103 K ECX,ECXWARD,ECXDEPT,ECXSVC,ECXDIV,ECXPUNIT,ECXSUF,ECXDESC
104 Q
Note: See TracBrowser for help on using the repository browser.