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

ECXDSSD.m

Go to the documentation of this file. 
  1. ECXDSSD ;ALB/JAP - Derive DSS Department code ;July 16, 1998
  1.  ;;3.0;DSS EXTRACTS;**8**;Dec 22, 1997
  1.  ;
  1. DERIVE(ECXSVC,ECXPUNIT,ECXDIV,ECXSUF) ;entry point for extrinsic function
  1.  ; input
  1.  ; ECXSVC = null or pointer to file #730; required
  1.  ; ECXPUNIT = null or pointer to file #729; required
  1.  ; ECXDIV = null or pointer to file #727.3; required
  1.  ; ECXSUF = null or character string; optional
  1.  ; output
  1.  ; DSSDEPT = dss department code as ABBCxxx or null
  1.  ;           A=DSS CODE from file (#730)
  1.  ;          BB=DSS PRODUCTION UNIT CODE from file (#729)
  1.  ;           C=DSS DIVISION IDENTIFIER from file (#727.3)
  1.  ;         xxx=suffix of not more than three characters (optional)
  1.  ;
  1.  N DSSDEPT
  1.  S DSSDEPT=""
  1.  Q:'$D(ECXSVC) DSSDEPT Q:'$D(ECXPUNIT) DSSDEPT Q:'$D(ECXDIV) DSSDEPT
  1.  D GETDIV(.ECXDIV)
  1.  I ECXDIV="" Q DSSDEPT
  1.  D GETSVC(.ECXSVC)
  1.  I ECXSVC="" Q DSSDEPT
  1.  D GETPUNIT(.ECXPUNIT)
  1.  I ECXPUNIT="" Q DSSDEPT
  1.  S DSSDEPT=ECXSVC_ECXPUNIT_ECXDIV
  1.  ;if variable ecxsuf does not exist, then do nothing
  1.  ;if variable ecxsuf is null, then assume user interaction for entry
  1.  ;if variable suffix is a character string, then assume no user interaction; validate ecxsuf
  1.  I $D(ECXSUF) D
  1.  .D GETSUF(.ECXSUF)
  1.  .S DSSDEPT=DSSDEPT_ECXSUF
  1.  Q DSSDEPT
  1.  ;
  1. GETDIV(ECXDIV) ;get division portion of dss dept code
  1.  ; input
  1.  ; ECXDIV = pointer to file #40.8 or null; required; passed by reference
  1.  ; output
  1.  ; ECXDIV = dss division identifier or null
  1.  N ECX,USER,DIC,DR,DIQ,DA,X,Y,DTOUT,DUOUT,JJ,SS
  1.  S USER=0
  1.  I ECXDIV="" D  Q:$D(DTOUT)!($D(DUOUT))!(+Y<1)
  1.  .W !!
  1.  .S USER=1
  1.  .S DIC(0)="AEMQZ",DIC="^ECX(727.3," D ^DIC
  1.  .S:+Y>0 ECXDIV=+Y Q
  1.  S DIC="^ECX(727.3,",DR="1;",DIQ(0)="E",DIQ="ECX",DA=ECXDIV
  1.  D EN^DIQ1
  1.  S ECXDIV=$G(ECX(727.3,ECXDIV,1,"E"))
  1.  I ECXDIV="",USER=1 D
  1.  .W !!,"The selected division does not yet have a"
  1.  .W !,"DSS Identifier code defined.",!
  1.  .W !,"Use the Enter/Edit DSS Division Identifier option"
  1.  .W !,"to associate a DSS identifier with this division.",!
  1.  .I $E(IOST)="C" D
  1.  ..S SS=22-$Y F JJ=1:1:SS W !
  1.  ..S DIR(0)="E" W ! D ^DIR K DIR W !
  1.  Q
  1.  ;
  1. GETSVC(ECXSVC) ;get service portion of dss dept code
  1.  ; input
  1.  ; ECXSVC = pointer to file #730 or null; required; passed by reference
  1.  ; output
  1.  ; ECXSVC = dss service code or null
  1.  N ECX,USER,DIC,DR,DIQ,X,Y,JJ,SS,DA,DTOUT,DUOUT
  1.  S USER=0
  1.  I ECXSVC="" D  Q:$D(DTOUT)!($D(DUOUT))!(+Y<1)
  1.  .W !!
  1.  .S USER=1
  1.  .S DIC(0)="AEMQZ",DIC="^ECC(730," D ^DIC
  1.  .S:+Y>0 ECXSVC=+Y
  1.  S DIC="^ECC(730,",DR="3;",DIQ(0)="E",DIQ="ECX",DA=ECXSVC
  1.  D EN^DIQ1
  1.  S ECXSVC=$G(ECX(730,ECXSVC,3,"E"))
  1.  I ECXSVC="",USER=1 D
  1.  .W !!,"The selected National Service does not have a"
  1.  .W !,"DSS Clinical Service code defined.",!
  1.  .W !,"It cannot be used in a DSS Department code.",!
  1.  .I $E(IOST)="C" D
  1.  ..S SS=22-$Y F JJ=1:1:SS W !
  1.  ..S DIR(0)="E" W ! D ^DIR K DIR W !
  1.  Q
  1.  ;
  1. GETPUNIT(ECXPUNIT) ;get production unit portion of dss dept code
  1.  ; input
  1.  ; ECXPUNIT = pointer to file #729 or null; required; passed by reference
  1.  ; output
  1.  ; ECXPUNIT = dss production unit code or null
  1.  N ECX,DIC,DR,DIQ,X,Y,DTOUT,DUOUT,DA
  1.  I ECXPUNIT="" D  Q:$D(DTOUT)!($D(DUOUT))!(+Y<1)
  1.  .W !!
  1.  .S DIC(0)="AEMQZ",DIC="^ECX(729," D ^DIC
  1.  .S:+Y>0 ECXPUNIT=+Y
  1.  S DIC="^ECX(729,",DR=".01;",DIQ(0)="E",DIQ="ECX",DA=ECXPUNIT
  1.  D EN^DIQ1
  1.  S ECXPUNIT=$G(ECX(729,ECXPUNIT,.01,"E"))
  1.  Q
  1.  ;
  1. GETSUF(ECXSUF) ;get suffix portion of dss dept code
  1.  ; input
  1.  ; ECXSUF = character string or null; required; passed by reference
  1.  ; output
  1.  ; ECXSUF = character string or null;
  1.  ;          input character string will be returned as null
  1.  N USER,AGAIN,LEN,ZERO,OUT,DIR,DIRUT,DTOUT,DUOUT,X,Y
  1.  ;ask user for input only if ecxsuf="", otherwise assume no user interaction
  1.  ;variable user acts as a flag --> if =1, then assume user interaction
  1.  S USER=0 S:ECXSUF="" USER=1,AGAIN=0
  1.  ;variable again acts as a flag --> if =1, don't ask user if he wants to enter suffix 
  1.  D SUF2
  1.  Q
  1. SUF2 ;ask user for input if necessary, then validate variable ecxsuf
  1.  I USER=1 D
  1.  .I AGAIN=0 D  Q:$D(DIRUT)!(Y=0)
  1.  ..W !!
  1.  ..S DIR(0)="YA",DIR("A")="Do you want to enter a suffix? ",DIR("B")="NO" K X,Y
  1.  ..D ^DIR K DIR
  1.  .W !!
  1.  .S AGAIN=0
  1.  .S DIR(0)="FA^1:3",DIR("A")="Enter suffix: " K X,Y
  1.  .D ^DIR K DIR
  1.  .Q:$D(DIRUT)  Q:(X="^")&(Y="^")
  1.  .S ECXSUF=Y,LEN=$L(ECXSUF)
  1.  .I ECXSUF["-" D
  1.  ..I $L(ECXSUF)=1 W !!,"Invalid ...try again." S ECXSUF="",AGAIN=1 Q
  1.  ..I $E(ECXSUF,1)'="-" D  Q
  1.  ...W !!,"The hyphen character < - > is only allowed as the"
  1.  ...W !!,"1st character in the suffix.",!
  1.  ...W !,"Try again...",!
  1.  ...S ECXSUF="",AGAIN=1
  1.  ..W !!,"The hyphen character < - > should not be used unless this"
  1.  ..W !,"DSS Department code was previously established in DSS/Austin."
  1.  ..W !
  1.  ..S DIR(0)="YA",DIR("A")="Do you want to remove the hyphen? ",DIR("B")="YES" K X,Y
  1.  ..D ^DIR K DIR
  1.  ..S:($D(DIRUT))!(Y=1) ECXSUF="" S:(Y=1) AGAIN=1
  1.  .Q:AGAIN=1
  1.  .S ZERO=0
  1.  .F I=1:1:LEN S X=$E(ECXSUF,I) D  Q:AGAIN=1
  1.  ..Q:X="-"&(I=1)
  1.  ..I X?1P D  Q:AGAIN=1
  1.  ...W !!,"There is an invalid punctuation character < "_X_" > in the suffix.",!
  1.  ...W !,"Try again...",!
  1.  ...S ECXSUF="",AGAIN=1
  1.  ..I X?1L D  Q:AGAIN=1
  1.  ...W !!,"There is an invalid lowercase character < "_X_" > in the suffix.",!
  1.  ...W !,"Try again...",!
  1.  ...S ECXSUF="",AGAIN=1
  1.  ..S:X="0" ZERO=ZERO+0 S:X'="0" ZERO=ZERO+1
  1.  .Q:AGAIN=1
  1.  .I ZERO=0 D
  1.  ..W !!,"There are too many zeroes in the suffix.",!
  1.  ..W !,"Try again...",!
  1.  ..S ECXSUF="",AGAIN=1
  1.  I USER=1,AGAIN=1 G SUF2
  1.  ;no user interaction; validate ecxsuf
  1.  I USER=0,ECXSUF]"" D
  1.  .S (ZERO,OUT)=0
  1.  .S LEN=$L(ECXSUF) I LEN>3 S ECXSUF="" Q
  1.  .F I=1:1:LEN S X=$E(ECXSUF,I) D  Q:OUT=1
  1.  ..I X="-",I'=1 S ECXSUF="",OUT=1
  1.  ..I X?1P,X'="-" S ECXSUF="",OUT=1
  1.  ..I X?1L S ECXSUF="",OUT=1
  1.  ..S:X="0" ZERO=ZERO+0 S:X'="0" ZERO=ZERO+1
  1.  .I ZERO=0 S ECXSUF=""
  1.  Q
  1.  ;
  1. DECODE ;allow user to decode a dss department code
  1.  N CODE,DESC,OUT,DIR,DIRUT,DTOUT,DUOUT,X,Y
  1.  W !!,"You may enter a DSS Department as 'ABBC' (no suffix)."
  1.  W !,"The code will be 'translated' into a description and displayed.",!!
  1.  S OUT=0
  1.  F  D  Q:OUT=1  Q:$D(DIRUT)
  1.  .S DIR(0)="FA^4:4",DIR("A")="Enter a DSS Department code: " K X,Y
  1.  .D ^DIR K DIR
  1.  .Q:$D(DIRUT)  Q:(X="^")&(Y="^")
  1.  .S CODE=Y D REVERSE(CODE,.DESC)
  1.  .W !
  1.  .W !?5,"Service ",?20,"<"_$E(CODE,1)_">  = "_$P(DESC,U,1)
  1.  .W !?5,"Prod. Unit ",?20,"<"_$E(CODE,2,3)_"> = "_$P(DESC,U,2)
  1.  .W !?5,"Division ",?20,"<"_$E(CODE,4)_">  = "_$P(DESC,U,3)
  1.  .W !
  1.  .S DIR(0)="YA",DIR("A")="Another one? ",DIR("B")="YES" K X,Y
  1.  .D ^DIR K DIR
  1.  .I Y=0 S OUT=1
  1.  Q
  1.  ;
  1. REVERSE(ECXDEPT,ECXDESC) ;get dss dept code description
  1.  ; input
  1.  ; ECXDEPT = dss dept code as ABBCxxx; required
  1.  ; output
  1.  ; ECXDESC = code description; passed by reference
  1.  ;           service_name^prod_unit_long_desc^division_name/station number
  1.  ;           note: if suffix (xxx) is present, it is ignored because free text
  1.  N SVC,PUNIT,DIV
  1.  Q:$L(ECXDEPT)<4
  1.  S SVC=$E(ECXDEPT,1),PUNIT=$E(ECXDEPT,2,3),DIV=$E(ECXDEPT,4)
  1.  K X,ECXERR S X=$$FIND1^DIC(730,,"X",SVC,"C",,"ECXERR")
  1.  S SVC=$S(X>0:$P(^ECC(730,X,0),U,1),X=0:"Not found",X="":"Error",1:"")
  1.  K X,ECXERR S X=$$FIND1^DIC(729,,"X",PUNIT,"B",,"ECXERR")
  1.  S PUNIT=$S(X>0:$P(^ECX(729,X,0),U,3),X=0:"Not found",X="":"Error",1:"")
  1.  K X,ECXERR S X=$$FIND1^DIC(727.3,,"X",DIV,"C",,"ECXERR")
  1.  S DIV=$S(X>0:$P(^DG(40.8,X,0),U,1)_"/"_$P(^(0),U,2),X=0:"Not found",X="":"Error",1:"")
  1.  S ECXDESC=SVC_U_PUNIT_U_DIV
  1.  Q