Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ECXDVSNX

ECXDVSNX.m

Go to the documentation of this file.
  1. ECXDVSNX ;ALB/JAP - Division Identifier for DSS ;July 16, 1998
  1. ;;3.0;DSS EXTRACTS;**8,24,33**;Dec 22, 1997
  1. ;
  1. EN ;entry point from menu option
  1. ;user adds any division to file #727.3
  1. N D,L,X,Y,YR,MON,FY,OUT,%,DIR,DIRUT,DTOUT,DUOUT,DIC,DIE,DR
  1. D NOW^%DTC S ECX=$$FMTE^XLFDT(%,"5D"),YR=+$P(ECX,"/",3),MON=+$P(ECX,"/",1),FY=$S(MON<10:YR,1:YR+1)
  1. S ECXFY=FY-1700,ECFYB=ECXFY-1_"1000",ECFYE=ECXFY_"1001"
  1. ;get all divisions active during this fiscal year
  1. D ALL^ECXDVSN2(.ECXDIV,1,ECFYB,ECFYE,.ECXERR)
  1. D SELECT
  1. G EXIT
  1. Q
  1. ;
  1. SELECT ;select division
  1. S DIR(0)="PAO^40.8",DIR("A")="Select Medical Center Division: " K X,Y
  1. S DIR("S")="I $D(ECXDIV(+Y))" K X,Y D ^DIR K DIR Q:$D(DIRUT)
  1. S ECXDIV=+Y
  1. W !!,"Division:",?20,$P(ECXDIV(ECXDIV),U,2)
  1. I $P(ECXDIV(ECXDIV),U,5)=0 W " **Inactive**"
  1. W !,"Station number:",?20,$P(ECXDIV(ECXDIV),U,3)
  1. W !,"Primary division?:",?20,$S(+$P(ECXDIV(ECXDIV),U,4):"Yes",1:"No")
  1. S DR="1;",DIQ(0)="E",DIQ="ECX",DA=ECXDIV,DIC="^ECX(727.3," K ECX D EN^DIQ1
  1. ;if division already has a dss identifier, then display it
  1. I $G(ECX(727.3,ECXDIV,1,"E"))]"" D Q:$D(DTOUT) G:Y=0 SELECT
  1. .W !,"DSS Identifier:",?20,ECX(727.3,ECXDIV,1,"E"),!
  1. .S DIR(0)="YA",DIR("A")="Do you want to change this identifier? ",DIR("B")="NO"
  1. .K X,Y D ^DIR K DIR
  1. ;allow user to enter/edit dss division identifier
  1. S OUT=0
  1. F D Q:$D(DIRUT)!(OUT=1)
  1. .W !
  1. .S DIR(0)="FA^1:1",DIR("A")="Enter the DSS Division Identifier: "
  1. .K X,Y D ^DIR K DIR Q:$D(DIRUT)
  1. .I X?.P!(X?.L)!($L(X)>1)!(X="0") W !,"Invalid ...try again.",! Q
  1. .I '$$CHKCODE(X,ECXDIV) W !,"Already used for another division ...try again.",! Q
  1. .S ECXID=X,OUT=1
  1. G:$D(DUOUT) SELECT
  1. Q:$D(DTOUT)
  1. ;if selected division isn't in file #727.3, then add it
  1. I '$D(ECX(727.3,ECXDIV)) D
  1. .S (X,DINUM)=ECXDIV,DIC(0)="L",DLAYGO=727.3,DIC="^ECX(727.3,"
  1. .K DD,DO D FILE^DICN K DINUM,DLAYGO,X,Y
  1. ;update with new identifier
  1. S DIE="^ECX(727.3,",DA=ECXDIV,DR="1////^S X=ECXID;" D ^DIE
  1. W !!
  1. G SELECT
  1. ;
  1. EXIT ;common exit point
  1. K ECX,ECXDIV,ECXERR,ECXFY,ECFYB,ECFYE
  1. Q
  1. ;
  1. CHKCODE(X,ECXDIV) ;make sure dss identifier is unique
  1. I '$D(^ECX(727.3,"C",X)) Q 1
  1. S XX=$O(^ECX(727.3,"C",X,0))
  1. I XX'=ECXDIV Q 0
  1. Q 1