- 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 Feb 18, 2025@23:18:58 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