ECXDVSNX ;ALB/JAP - Division Identifier for DSS ;July 16, 1998
;;3.0;DSS EXTRACTS;**8,24,33**;Dec 22, 1997
;
EN ;entry point from menu option
;user adds any division to file #727.3
N D,L,X,Y,YR,MON,FY,OUT,%,DIR,DIRUT,DTOUT,DUOUT,DIC,DIE,DR
D NOW^%DTC S ECX=$$FMTE^XLFDT(%,"5D"),YR=+$P(ECX,"/",3),MON=+$P(ECX,"/",1),FY=$S(MON<10:YR,1:YR+1)
S ECXFY=FY-1700,ECFYB=ECXFY-1_"1000",ECFYE=ECXFY_"1001"
;get all divisions active during this fiscal year
D ALL^ECXDVSN2(.ECXDIV,1,ECFYB,ECFYE,.ECXERR)
D SELECT
G EXIT
Q
;
SELECT ;select division
S DIR(0)="PAO^40.8",DIR("A")="Select Medical Center Division: " K X,Y
S DIR("S")="I $D(ECXDIV(+Y))" K X,Y D ^DIR K DIR Q:$D(DIRUT)
S ECXDIV=+Y
W !!,"Division:",?20,$P(ECXDIV(ECXDIV),U,2)
I $P(ECXDIV(ECXDIV),U,5)=0 W " **Inactive**"
W !,"Station number:",?20,$P(ECXDIV(ECXDIV),U,3)
W !,"Primary division?:",?20,$S(+$P(ECXDIV(ECXDIV),U,4):"Yes",1:"No")
S DR="1;",DIQ(0)="E",DIQ="ECX",DA=ECXDIV,DIC="^ECX(727.3," K ECX D EN^DIQ1
;if division already has a dss identifier, then display it
I $G(ECX(727.3,ECXDIV,1,"E"))]"" D Q:$D(DTOUT) G:Y=0 SELECT
.W !,"DSS Identifier:",?20,ECX(727.3,ECXDIV,1,"E"),!
.S DIR(0)="YA",DIR("A")="Do you want to change this identifier? ",DIR("B")="NO"
.K X,Y D ^DIR K DIR
;allow user to enter/edit dss division identifier
S OUT=0
F D Q:$D(DIRUT)!(OUT=1)
.W !
.S DIR(0)="FA^1:1",DIR("A")="Enter the DSS Division Identifier: "
.K X,Y D ^DIR K DIR Q:$D(DIRUT)
.I X?.P!(X?.L)!($L(X)>1)!(X="0") W !,"Invalid ...try again.",! Q
.I '$$CHKCODE(X,ECXDIV) W !,"Already used for another division ...try again.",! Q
.S ECXID=X,OUT=1
G:$D(DUOUT) SELECT
Q:$D(DTOUT)
;if selected division isn't in file #727.3, then add it
I '$D(ECX(727.3,ECXDIV)) D
.S (X,DINUM)=ECXDIV,DIC(0)="L",DLAYGO=727.3,DIC="^ECX(727.3,"
.K DD,DO D FILE^DICN K DINUM,DLAYGO,X,Y
;update with new identifier
S DIE="^ECX(727.3,",DA=ECXDIV,DR="1////^S X=ECXID;" D ^DIE
W !!
G SELECT
;
EXIT ;common exit point
K ECX,ECXDIV,ECXERR,ECXFY,ECFYB,ECFYE
Q
;
CHKCODE(X,ECXDIV) ;make sure dss identifier is unique
I '$D(^ECX(727.3,"C",X)) Q 1
S XX=$O(^ECX(727.3,"C",X,0))
I XX'=ECXDIV Q 0
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXDVSNX 2215 printed Oct 16, 2024@17:53:21 Page 2
ECXDVSNX ;ALB/JAP - Division Identifier for DSS ;July 16, 1998
+1 ;;3.0;DSS EXTRACTS;**8,24,33**;Dec 22, 1997
+2 ;
EN ;entry point from menu option
+1 ;user adds any division to file #727.3
+2 NEW D,L,X,Y,YR,MON,FY,OUT,%,DIR,DIRUT,DTOUT,DUOUT,DIC,DIE,DR
+3 DO NOW^%DTC
SET ECX=$$FMTE^XLFDT(%,"5D")
SET YR=+$PIECE(ECX,"/",3)
SET MON=+$PIECE(ECX,"/",1)
SET FY=$SELECT(MON<10:YR,1:YR+1)
+4 SET ECXFY=FY-1700
SET ECFYB=ECXFY-1_"1000"
SET ECFYE=ECXFY_"1001"
+5 ;get all divisions active during this fiscal year
+6 DO ALL^ECXDVSN2(.ECXDIV,1,ECFYB,ECFYE,.ECXERR)
+7 DO SELECT
+8 GOTO EXIT
+9 QUIT
+10 ;
SELECT ;select division
+1 SET DIR(0)="PAO^40.8"
SET DIR("A")="Select Medical Center Division: "
KILL X,Y
+2 SET DIR("S")="I $D(ECXDIV(+Y))"
KILL X,Y
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
+3 SET ECXDIV=+Y
+4 WRITE !!,"Division:",?20,$PIECE(ECXDIV(ECXDIV),U,2)
+5 IF $PIECE(ECXDIV(ECXDIV),U,5)=0
WRITE " **Inactive**"
+6 WRITE !,"Station number:",?20,$PIECE(ECXDIV(ECXDIV),U,3)
+7 WRITE !,"Primary division?:",?20,$SELECT(+$PIECE(ECXDIV(ECXDIV),U,4):"Yes",1:"No")
+8 SET DR="1;"
SET DIQ(0)="E"
SET DIQ="ECX"
SET DA=ECXDIV
SET DIC="^ECX(727.3,"
KILL ECX
DO EN^DIQ1
+9 ;if division already has a dss identifier, then display it
+10 IF $GET(ECX(727.3,ECXDIV,1,"E"))]""
Begin DoDot:1
+11 WRITE !,"DSS Identifier:",?20,ECX(727.3,ECXDIV,1,"E"),!
+12 SET DIR(0)="YA"
SET DIR("A")="Do you want to change this identifier? "
SET DIR("B")="NO"
+13 KILL X,Y
DO ^DIR
KILL DIR
End DoDot:1
if $DATA(DTOUT)
QUIT
if Y=0
GOTO SELECT
+14 ;allow user to enter/edit dss division identifier
+15 SET OUT=0
+16 FOR
Begin DoDot:1
+17 WRITE !
+18 SET DIR(0)="FA^1:1"
SET DIR("A")="Enter the DSS Division Identifier: "
+19 KILL X,Y
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
+20 IF X?.P!(X?.L)!($LENGTH(X)>1)!(X="0")
WRITE !,"Invalid ...try again.",!
QUIT
+21 IF '$$CHKCODE(X,ECXDIV)
WRITE !,"Already used for another division ...try again.",!
QUIT
+22 SET ECXID=X
SET OUT=1
End DoDot:1
if $DATA(DIRUT)!(OUT=1)
QUIT
+23 if $DATA(DUOUT)
GOTO SELECT
+24 if $DATA(DTOUT)
QUIT
+25 ;if selected division isn't in file #727.3, then add it
+26 IF '$DATA(ECX(727.3,ECXDIV))
Begin DoDot:1
+27 SET (X,DINUM)=ECXDIV
SET DIC(0)="L"
SET DLAYGO=727.3
SET DIC="^ECX(727.3,"
+28 KILL DD,DO
DO FILE^DICN
KILL DINUM,DLAYGO,X,Y
End DoDot:1
+29 ;update with new identifier
+30 SET DIE="^ECX(727.3,"
SET DA=ECXDIV
SET DR="1////^S X=ECXID;"
DO ^DIE
+31 WRITE !!
+32 GOTO SELECT
+33 ;
EXIT ;common exit point
+1 KILL ECX,ECXDIV,ECXERR,ECXFY,ECFYB,ECFYE
+2 QUIT
+3 ;
CHKCODE(X,ECXDIV) ;make sure dss identifier is unique
+1 IF '$DATA(^ECX(727.3,"C",X))
QUIT 1
+2 SET XX=$ORDER(^ECX(727.3,"C",X,0))
+3 IF XX'=ECXDIV
QUIT 0
+4 QUIT 1
