source: WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXDVSNX.m@ 1766

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

initial load of WorldVistAEHR

File size: 2.1 KB
Line 
1ECXDVSNX ;ALB/JAP - Division Identifier for DSS ;July 16, 1998
2 ;;3.0;DSS EXTRACTS;**8,24,33**;Dec 22, 1997
3 ;
4EN ;entry point from menu option
5 ;user adds any division to file #727.3
6 N D,L,X,Y,YR,MON,FY,OUT,%,DIR,DIRUT,DTOUT,DUOUT,DIC,DIE,DR
7 D NOW^%DTC S ECX=$$FMTE^XLFDT(%,"5D"),YR=+$P(ECX,"/",3),MON=+$P(ECX,"/",1),FY=$S(MON<10:YR,1:YR+1)
8 S ECXFY=FY-1700,ECFYB=ECXFY-1_"1000",ECFYE=ECXFY_"1001"
9 ;get all divisions active during this fiscal year
10 D ALL^ECXDVSN2(.ECXDIV,1,ECFYB,ECFYE,.ECXERR)
11 D SELECT
12 G EXIT
13 Q
14 ;
15SELECT ;select division
16 S DIR(0)="PAO^40.8",DIR("A")="Select Medical Center Division: " K X,Y
17 S DIR("S")="I $D(ECXDIV(+Y))" K X,Y D ^DIR K DIR Q:$D(DIRUT)
18 S ECXDIV=+Y
19 W !!,"Division:",?20,$P(ECXDIV(ECXDIV),U,2)
20 I $P(ECXDIV(ECXDIV),U,5)=0 W " **Inactive**"
21 W !,"Station number:",?20,$P(ECXDIV(ECXDIV),U,3)
22 W !,"Primary division?:",?20,$S(+$P(ECXDIV(ECXDIV),U,4):"Yes",1:"No")
23 S DR="1;",DIQ(0)="E",DIQ="ECX",DA=ECXDIV,DIC="^ECX(727.3," K ECX D EN^DIQ1
24 ;if division already has a dss identifier, then display it
25 I $G(ECX(727.3,ECXDIV,1,"E"))]"" D Q:$D(DTOUT) G:Y=0 SELECT
26 .W !,"DSS Identifier:",?20,ECX(727.3,ECXDIV,1,"E"),!
27 .S DIR(0)="YA",DIR("A")="Do you want to change this identifier? ",DIR("B")="NO"
28 .K X,Y D ^DIR K DIR
29 ;allow user to enter/edit dss division identifier
30 S OUT=0
31 F D Q:$D(DIRUT)!(OUT=1)
32 .W !
33 .S DIR(0)="FA^1:1",DIR("A")="Enter the DSS Division Identifier: "
34 .K X,Y D ^DIR K DIR Q:$D(DIRUT)
35 .I X?.P!(X?.L)!($L(X)>1)!(X="0") W !,"Invalid ...try again.",! Q
36 .I '$$CHKCODE(X,ECXDIV) W !,"Already used for another division ...try again.",! Q
37 .S ECXID=X,OUT=1
38 G:$D(DUOUT) SELECT
39 Q:$D(DTOUT)
40 ;if selected division isn't in file #727.3, then add it
41 I '$D(ECX(727.3,ECXDIV)) D
42 .S (X,DINUM)=ECXDIV,DIC(0)="L",DLAYGO=727.3,DIC="^ECX(727.3,"
43 .K DD,DO D FILE^DICN K DINUM,DLAYGO,X,Y
44 ;update with new identifier
45 S DIE="^ECX(727.3,",DA=ECXDIV,DR="1////^S X=ECXID;" D ^DIE
46 W !!
47 G SELECT
48 ;
49EXIT ;common exit point
50 K ECX,ECXDIV,ECXERR,ECXFY,ECFYB,ECFYE
51 Q
52 ;
53CHKCODE(X,ECXDIV) ;make sure dss identifier is unique
54 I '$D(^ECX(727.3,"C",X)) Q 1
55 S XX=$O(^ECX(727.3,"C",X,0))
56 I XX'=ECXDIV Q 0
57 Q 1
Note: See TracBrowser for help on using the repository browser.