| 1 | ECXDVSNX ;ALB/JAP - Division Identifier for DSS ;July 16, 1998
|
|---|
| 2 | ;;3.0;DSS EXTRACTS;**8,24,33**;Dec 22, 1997
|
|---|
| 3 | ;
|
|---|
| 4 | EN ;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 | ;
|
|---|
| 15 | SELECT ;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 | ;
|
|---|
| 49 | EXIT ;common exit point
|
|---|
| 50 | K ECX,ECXDIV,ECXERR,ECXFY,ECFYB,ECFYE
|
|---|
| 51 | Q
|
|---|
| 52 | ;
|
|---|
| 53 | CHKCODE(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
|
|---|
