ORUTL ;SLC/DCM,RWF - ORDER UTILITIES ;11/02/2017 17:00
;;3.0;ORDER ENTRY/RESULTS REPORTING;**95,280,218,350,422,377**;Dec 17, 1997;Build 582
ISCLORD(ORY,ORIFN) ;;RPC to test if an order is a clinic order
S ORIFN=+ORIFN
S ORY=0
I 'ORIFN Q
N ORZ0 S ORZ0=$G(^OR(100,ORIFN,0))
N ORTO S ORTO=$P(ORZ0,U,11)
I ORTO=$$CLINMDDG S ORY=1
I ORTO=$$CLINIVDG S ORY=1
Q
CLINMDDG() ;RETURN THE IEN OF THE CLINIC MEDICATIONS DISPLAY GROUP
Q $O(^ORD(100.98,"B","CLINIC MEDICATIONS",0))
CLINIVDG() ;RETURN THE IEN OF THE CLINIC INFUSIONS DISPLAY GROUP
Q $O(^ORD(100.98,"B","CLINIC INFUSIONS",0))
LOC ;;GET PT. LOCATION
S C(1)=$S($D(ORL(2))#2:$S(ORL(2)[";":$S($D(@("^"_$P(ORL(2),";",2)_+ORL(2)_",0)")):$P(^(0),"^"),1:""),1:""),1:"")
I 'OR4,ORVP[";DPT(",$D(ORL(2)),ORL(2) Q
G:$L(C(1)) LOC1 S (CT,C)=0,O=1 I ORVP[";DPT(",$O(^DPT(+ORVP,"DE",0))>0 W !!,"Currently enrolled in the following clinics: ",!
I S I=0 F L=0:0 S I=$O(^DPT(+ORVP,"DE",I)) Q:I'>0 I $D(^(I,0)) S Y=^(0) I $P(Y,"^",2)'="I",'$P(Y,"^",3) I $D(^SC(+Y,0)) S X=^(0) D
. I $D(^SC(+Y,"I")) S ORIA=+^("I"),ORRA=$P(^("I"),"^",2) I $S('ORIA:0,ORIA>DT:0,ORRA'>DT&(ORRA):0,1:1) Q
. S CT=CT+1 W:(CT#2) !?17 W:'(CT#2) ?47 W $P(X,"^") S C=C+1,C(1)=$P(X,"^") S:C'=1 C=-1
W !
LOC1 S C=1 W !,"Patient Location: " W:C=1&($L(C(1))) C(1),"//" R X:DTIME G QUIT:'$T,QUIT:C'=1&(X=""),LOC:$L(X)>20!(X'?.ANP),QUIT:X[U
S DIC("S")="I ""FI""'[$P(^(0),""^"",3),'$P($G(^(""OOS"")),""^"")",DIC=44,DIC(0)=$S(C=1&($L(C(1)))&(X=""):"EMQOZX",1:"EMQZ")
S:X="" X=C(1) D ^DIC G LOC:X["?" S:Y>0 ORL=+Y_";SC(",ORL(0)=$S($L($P(Y(0),"^",2)):$P(Y(0),"^",2),1:$E($P(Y(0),"^"),1,4))
K ORIA,ORRA I $D(^SC(+Y,"I")) S ORIA=+^("I"),ORRA=$P(^("I"),U,2)
I $S('$D(ORIA):0,'ORIA:0,ORIA>DT:0,ORRA'>DT&(ORRA):0,1:1) W $C(7)," This location has been inactivated." K ORL G LOC
I Y<0 W " You must select a standard location." G LOC
K DIC,C,ORIA,ORRA Q
QUIT S OREND=1 K DIC,C Q
READ ;;Hold screen
I $D(IOST) Q:$E(IOST)'="C"
W ! I $D(IOSL),$Y<(IOSL-4) G READ
W !?5,"Press return to continue " R X:$S($D(DTIME):DTIME,1:300)
Q
CHKNAM(X,Y) ;Input transform to not allow certain characters
;X is the text to be checked, Y are the characters not allowed as sent in by the input transform of the field
N I,J I '$D(Y) S Y=";^" ;if no special characters sent in, set list to all
F I=1:1:$L(Y) I X[($E(Y,I)) S J=1
Q +$G(J)
CHKMNE(X) ;Input transform to not allow use of standard Lmgr Mnemonics
N Y
S Y=$$UP^XLFSTR(X) ;check to make sure mnemonic isn't set to lower case of restricted entries. List Manager is case insensitive
I Y="ADPL"!(Y="DN")!(Y="Q")!(Y="FS")!(Y="GO")!(Y="?")!(Y="??")!(Y="LS")!(Y="+")!(Y="-")!(Y="PL")!(Y="PS")!(Y="RD")!(Y="SL")!(Y="<")!(Y=">")!(Y="UP")!(Y="PI")!(Y="CWAD")!(Y="TD")!(Y="EX") Q 1
Q 0
PAD(ORX,ORL) ; Pads string to specified length
N ORY
S ORY="",$P(ORY," ",(ORL-$L(ORX))+1)=""
Q ORY
MAIL(XMTEXT,XMSUB,XMY,SUBSCR) ;SEND AN EMAIL
;PARAMETERS: XMTEXT => STRING CONTAINING NAME OF ARRAY CONTAINING MESSAGE TEXT (REQUIRED)
; XMSUB => STRING CONTAINING THE SUBJECT OF THE MESSAGE (REQUIRED)
; XMY => REFERENCE TO AN ARRAY CONTAINING THE RECIPIENTS (OPTIONAL)
; SUBSCR => STRING CONTAINING THE SUBSCIPT WITHIN ^XTMP WHERE RECIPIENTS ARE STORED (OPTIONAL)
;RETURN: $$MAIL => STRING CONTAINING XMMG (ERROR STRING)^XMERR (NUMBER OF ERRORS)
N XMMG,XMDUZ,XMZ,XMERR,DIFROM,ORMSG
Q:'$D(XMTEXT)!($G(XMSUB)="")
I $D(XMY)=0 D
.I $G(SUBSCR)'="",($Q(^XTMP(SUBSCR,0))[SUBSCR) D Q
..K ^XTMP(SUBSCR,0)
..M XMY=^XTMP(SUBSCR)
..K ^XTMP(SUBSCR)
.I $D(ZTQUEUED)>0 D
..S XMY(DUZ)=""
.E D
..S ORMSG(1)=" "
..S ORMSG(2)="Select the recipient(s) of the report below."
..D MAILOUT(.ORMSG)
S XMDUZ="POSTMASTER" ;FORCE SENDER TO BE POSTMASTER
D ^XMD ;ICR #10070
K ORMSG
I $D(XMMG)>0 D
.S ORMSG(1)=" "
.S ORMSG(2)="Unable to email the report:"
.S ORMSG(3)=XMMG
.D MAILOUT(.ORMSG)
Q $G(XMMG)_U_$G(XMERR)
MAILOUT(MESSAGE) ;OUTPUT THE ORMSG ARRAY FROM MAIL LINE TAG
;IF KIDS IS NOT EXECUTING, OUTPUT THE MESSAGE TO THE SCREEN
I $G(XPDNM)="" D
.N LINE S LINE=0 F S LINE=$O(MESSAGE(LINE)) Q:+$G(LINE)=0 W MESSAGE(LINE),!
E D MES^XPDUTL(.MESSAGE)
Q
WRAP(ORLINE,OROUTPUT,ORDINDEN,ORTRIM,OROI,ORCNT,ORIOM,ORZERO) ;WRAP THE TEXT SO
; THAT IT IS NO MORE THAN X CHARACTERS WIDE
;PARAMETERS: ORLINE =>SINGLE LINE OF TEXT TO WRAP
; OROUTPUT=>NAME OF ARRAY THAT WILL STORE THE WRAPPED TEXT IN THE FORMAT:
; OROUTPUT=NUMBER OF LINES OF TEXT RETURNED
; OROUTPUT(N)=LINE N OF TEXT
; ORDINDEN=>FOR RETURNED TEXT, DETERMINE WHETHER TO INDENT LINES 2 THROUGH LAST (1) OR NOT (0)
; DEFAULT: 1
; ORTRIM =>FOR RETURNED TEXT, STRIP TRAILING SPACES ON EACH LINE (1) OR NOT (0)
; DEFAULT: 1
; OROI =>FOR RETURNED TEXT, THE COLUMN NUMBER TO INDENT LINES 2 THROUGH LAST TO
; DEFAULT: CALCULATE COLUMN TO INDENT TO
; ORCNT =>'$D(ORCNT) - RETURN NUMBER OF LINES IN RETURN ARRAY (OROUTPUT=N)
; $D(ORCNT)=1 - RETURN NUMBER OF LINES IN ORCNT
; ORIOM =>HOW WIDE EACH LINE SHOULD BE
; +ORIOM=0 - USES EITHER VALUE IN IOM OR 80
; ORZERO =>FOR RETURNED TEXT, RETURN TEXT IN A ZERO SUBSCRIPT DESCENDENT FROM THE LINE
; NUMBER SUBSCRIPT (1) OR NOT (0)
; DEFAULT: 0
N ORRETURN,ORTEMP,ORINDENT,ORLCNT
S ORDINDEN=+$G(ORDINDEN,1),ORTRIM=+$G(ORTRIM,1),OROI=+$G(OROI),ORZERO=+$G(ORZERO)
I $D(ORCNT) S ORLCNT=ORCNT
I $G(@OROUTPUT)>0 S ORLCNT=@OROUTPUT
S ORIOM=+$S($G(ORIOM)>0:ORIOM,$G(IOM)>0:IOM,1:80)
I ORDINDEN,'OROI D
.N ORCHR
.I ORLINE[":",($L($P(ORLINE,":"))<ORIOM) S ORINDENT=$$REPEAT^XLFSTR(" ",$L($P(ORLINE,":"))+2)
.I ORLINE'[":",($E(ORLINE,1)=" ") D
..F ORCHR=1:1:$L(ORLINE) Q:$E(ORLINE,ORCHR)'=" "
..S ORINDENT=$$REPEAT^XLFSTR(" ",ORCHR-1)
.I ORLINE'[":",($E(ORLINE,1)'=" ") D
..N START,END
..F ORCHR=1:1:$L(ORLINE) Q:+$G(END) D
...I '+$G(START),($E(ORLINE,ORCHR)=" "),($E(ORLINE,ORCHR+1)=" ") S START=1
...I +$G(START),($E(ORLINE,ORCHR)'=" ") S END=1
..S:+$G(START)>0 ORINDENT=$$REPEAT^XLFSTR(" ",ORCHR-2)
I ORDINDEN,OROI>0 S ORINDENT=$$REPEAT^XLFSTR(" ",OROI)
S ORTEMP=1,ORTEMP(ORTEMP)=ORLINE
F Q:$L(ORTEMP(ORTEMP))<(ORIOM+1) D
.N ORTEMP1,ORCHR
.F ORCHR=ORIOM:-1:1 Q:$E(ORTEMP(ORTEMP),ORCHR)=" "
.S:ORCHR=1 ORCHR=ORIOM
.I ORDINDEN,ORCHR=$L($G(ORINDENT)) S ORCHR=ORIOM
.S ORTEMP1=ORTEMP(ORTEMP)
.S ORTEMP(ORTEMP)=$E(ORTEMP1,1,ORCHR)
.S:ORTRIM ORTEMP(ORTEMP)=$$TRIM^XLFSTR(ORTEMP(ORTEMP),"R")
.S ORTEMP=ORTEMP+1
.S ORTEMP(ORTEMP)=$G(ORINDENT)_$E(ORTEMP1,ORCHR+1,*)
S ORTEMP=0 F S ORTEMP=$O(ORTEMP(ORTEMP)) Q:+ORTEMP=0 D
.S ORLCNT=1+$G(ORLCNT)
.I ORZERO S @OROUTPUT@(ORLCNT,0)=ORTEMP(ORTEMP)
.I 'ORZERO S @OROUTPUT@(ORLCNT)=ORTEMP(ORTEMP)
I '$D(ORCNT) S @OROUTPUT=ORLCNT
E S ORCNT=ORLCNT
Q
DEVICE(ZTRTN,ZTDESC,%ZIS,ZTSAVE) ;PROMPT THE USER FOR THE OUTPUT DEVICE
;PARAMETERS: ZTRTN => LINE TAG THAT STARTS PRINTING THE REPORT
; ZTDESC => TASKMAN TASK DESCRIPTION
; %ZIS => FLAGS TO PASS TO ^%ZIS
; ZTSAVE => VARIABLES TO SAVE FOR TASKMAN
N POP,CBUFFER
S %ZIS("B")="",CBUFFER=0
D ^%ZIS
Q:+$G(POP)
I $D(IO("Q")) D Q
.N ZTSK,ORTEXT
.S ORTEXT=$P(ZTDESC,"OR ",2)
.S ZTSAVE("CBUFFER")=""
.D ^%ZTLOAD,HOME^%ZIS
.K IO("Q")
.I +$G(ZTSK)>0 W !,"Successfully queued the "_ORTEXT_" report.",!,"Task Number: "_ZTSK,! H 2
I '$D(IO("Q")) D
.U IO
.I $E(IOST,1,2)="C-" W @IOF S CBUFFER=3
.D @ZTRTN,^%ZISC
Q
;PARAMETERS: TITLE => THE TITLE OF THE REPORT
; PAGE => (REFERENCE) PAGE NUMBER
; HEADER => (REFERENCE) COLUMN NAMES, FORMATTED AS:
; COLUMN(LINE_NUMBER)=TEXT
; NOTE: LINE_NUMBER STARTS AT ONE
; NEWRPT => (OPTIONAL) ALLOWS PRINTING OF MULTIPLE REPORTS
; ONE AFTER THE OTHER
; UNDEFINED: NOT PRINTING MULTIPLE REPORTS
; 0 (DEFAULT): THIS IS NOT THE START OF A
; NEW REPORT
; 1: THIS IS THE START OF A NEW REPORT
;RETURNS: 0 => USER WANTS TO CONTINUE PRINTING
; 1 => USER DOES NOT WANT TO CONTINUE PRINTING
Q:$$STOPTASK 1
N X,END
S PAGE=1+$G(PAGE)
I PAGE>1!(+$G(NEWRPT)) D Q:$G(END) 1
.I $E(IOST,1,2)="C-" W !,"Press RETURN to continue or '^' to exit: " R X:DTIME S END='$T!(X=U) Q:$G(END)
.I $Y>0,$Y<=IOSL W @IOF
.I $Y>IOSL S $Y=0
I PAGE=1,($E(IOST,1,2)="C-"),('+$G(NEWRPT)) W @IOF
N NOW,INDEX
S NOW=$$UP^XLFSTR($$HTE^XLFDT($H)),NOW=$P(NOW,"@",1)_" "_$P($P(NOW,"@",2),":",1,2)
W $$LJ^XLFSTR($E(TITLE,1,46),47," ")_NOW_" PAGE "_PAGE,!
S INDEX=0 F S INDEX=$O(HEADER(INDEX)) Q:'INDEX W HEADER(INDEX),!
W $$REPEAT^XLFSTR("-",(IOM-1)),!
Q 0
STOPTASK() ;DETERMINE IF TASKMAN HAS ASKED PROCESS TO STOP
;RETURNS: 0 => TASKMAN HAS NOT ASKED TASK TO STOP
; 1 => TASKMAN HAS ASKED TASK TO STOP
I $D(ZTQUEUED),($$S^%ZTLOAD) D Q:$G(ZTSTOP)=1 1
.S ZTSTOP=$$S^%ZTLOAD("Received stop request"),ZTSTOP=1
Q 0
FMERROR(ERROR) ;OUTPUT FILEMAN ERROR
;PARAMETERS: ERROR => (REFERENCE) ARRAY CONTAINING THE FILEMAN ERROR
N OUT
W !!,"Unable to generate the report due to the following FileMan error:",!
W "FILEMAN ERROR #"_ERROR("DIERR",1)_":",!
N IDX S IDX="" F S IDX=$O(ERROR("DIERR",1,"TEXT",IDX)) Q:'IDX D WRAP(ERROR("DIERR",1,"TEXT",IDX),"OUT")
S IDX=0 F S IDX=$O(OUT(IDX)) Q:+$G(IDX)=0 W OUT(IDX),!
Q
DIVPRMPT(DIV) ;PROMPT THE USER FOR WHICH ACTIVE DIVISION(S)
;PARAMETERS: DIV => REFERENCE TO ARRAY WHICH WILL CONTAIN THE SELECTED DIVISION(S) WHEN THIS FINISHES
; FORMAT: DIV(FILE #4 IEN)=INSTITUTION NAME
; IF THE USER SELECTS ALL DIVISIONS, THEN ONLY THE FOLLOWING IS RETURNED:
; DIV("ALL")="all divisions"
;RETURNS: -1 USER ENTERED CARET AT PROMPT IF SITE IS MULTIDIVISIONAL
; 0 INSTITUTION FILE POINTER IS MISSING FOR ALL SELECTED DIVISIONS
; 1 SUCCESSFUL SELECTION OF DIVISION(S)
N SELDIV,BADDIV,TIUDI,IDX,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,COUNT,DELIMIT
F D Q:+$G(SELDIV)=1!(+$G(SELDIV)=-1)
.D SELDIV^TIULA
.S IDX=0 F S IDX=$O(TIUDI(IDX)) Q:+$G(IDX)=0 D
..S DIV(TIUDI(IDX))=$P($$SITE^VASITE(,IDX),U,2),COUNT=1+$G(COUNT)
.I SELDIV=1,('$D(DIV)) S DIV("ALL")="all divisions"
.I $D(BADDIV) D
..N TEXT,OUTPUT
..S DELIMIT=", "
..F IDX=1:1:$L(BADDIV,",") D
...S:IDX=$L(BADDIV,",") DELIMIT=" and "
...S TEXT=$S($G(TEXT)'="":TEXT_DELIMIT,1:"")_$P(BADDIV,",",IDX)
..S BADDIV="I'm sorry, but "_TEXT_" "_$S($L(BADDIV,",")=1:"is not a valid division.",$L(BADDIV,",")>1:"are not valid divisions.",1:"you selected an invalid division.")
..D WRAP^ORUTL(BADDIV,"OUTPUT")
..W !!
..F IDX=1:1:OUTPUT W OUTPUT(IDX),!
..I $D(DIV) D
...S DIR(0)="Y"_U,DIR("A")="Do you want to continue with the valid division"_$S(COUNT>1:"s",1:"")_" already selected"
...S DIR("B")="YES"
...D ^DIR
...Q:$D(DIRUT)
...S:Y SELDIV=1
Q SELDIV
HASDIV(Y,DIV,RET) ;DETERMINE IF THE SPECIFIED USER BELONGS TO A SET OF DIVISIONS RETURNED BY DIVPRMPT^ORUTL
;PARAMETERS: Y => IEN IN THE NEW PERSON FILE (#200)
; DIV => REFERENCE TO ARRAY CONTAINING SELECTED DIVISIONS
; FORMAT: DIV(FILE_#4_IEN)=INSTITUTION NAME
; DIV("FOUND",FILE_#4_IEN)=INSTITUTION NAME <-- FOR DISCOVERED DIVISIONS
; RET => 1 TO RETURN DISCOVERED DIVISIONS IN DIV ARRAY, WHEN "ALL DIVISIONS" ARE SELECTED
; 0 TO NOT RETURN DISCOVERED DIVISIONS (DEFAULT)
;RETURNS: NAME OF Y'S DIVISION
; EMPTY STRING IF Y'S DIVISION IS NOT A SELECTED DIVISION
N DIVISION S DIVISION=""
S RET=+$G(RET)
I $D(DIV) D
.N DIVISIONS,IDX,HASDIV
.;IA #2533
.S HASDIV=$$DIV4^XUSER(.DIVISIONS,Y)
.I HASDIV=0 D
..N IEN
..S IEN=$P($$SITE^VASITE(),U)
..S:+IEN=0 IEN=DUZ(2)
..S DIVISIONS(IEN)=1
.I $G(DIV("ALL"))="all divisions" D Q
..N IEN
..S IEN=0 F S IEN=$O(DIVISIONS(IEN)) Q:'+IEN D
...I DIVISIONS(IEN) D
....S DIVISION=$$GET1^DIQ(4,IEN_",",.01)
....S:RET DIV("FOUND",IEN)=DIVISION
..I DIVISION="" D
...S IEN=$O(DIVISIONS(0)),DIVISION=$$GET1^DIQ(4,IEN_",",.01)
...S:RET DIV("FOUND",IEN)=DIVISION
.S IDX=0 F S IDX=$O(DIVISIONS(IDX)) Q:+$G(IDX)=0 D
..I $D(DIV(IDX)) D
...I DIVISION'="",(DIVISIONS(IDX)=1) S DIVISION=DIV(IDX)
...I DIVISION="" S DIVISION=DIV(IDX)
Q DIVISION
LHASDIV(LOC,DIV,RET) ;DETERMINE IF THE SPECIFIED LOCATION BELONGS TO A SET OF DIVISIONS RETURNED BY DIVPRMPT^ORUTL
;PARAMETERS: LOC => VARIABLE POINTER TO HOSPITAL LOCATION FILE (#44)
; DIV => REFERENCE TO ARRAY CONTAINING SELECTED DIVISIONS
; FORMAT: DIV(FILE_#4_IEN)=INSTITUTION NAME
; DIV("FOUND",FILE_#4_IEN)=INSTITUTION NAME <-- FOR DISCOVERED DIVISIONS
; RET => 1 TO RETURN DISCOVERED DIVISIONS IN DIV ARRAY, WHEN "ALL DIVISIONS" ARE SELECTED
; 0 TO NOT RETURN DISCOVERED DIVISIONS (DEFAULT)
;RETURNS: NAME OF LOC'S DIVISION
; EMPTY STRING IF LOC'S DIVISION IS NOT A SELECTED DIVISION
N DIVISION,LOCDIV
S DIVISION="",LOCDIV=0,LOC=$G(LOC),RET=+$G(RET)
I $D(DIV) D
.I LOC>0 D
..N GLOREF,HLIEN
..S GLOREF=U_$$UP^XLFSTR($P(LOC,";",2))_+LOC_",0)"
..I GLOREF'?1"^SC("1.N1",0)" Q
..;IA #10040
..S LOCDIV=$P($G(@GLOREF),U,15)
..I +LOCDIV D
...N ORFND
...;IA #2817
...S ORFND=0,HLIEN=0 F S HLIEN=$O(^DG(40.8,"AD",HLIEN)) Q:HLIEN="" D
....I $D(^DG(40.8,"AD",HLIEN,LOCDIV)) D
.....S ORFND=1
.....I '$D(DIV("ALL")),$D(DIV(HLIEN)) S DIVISION=DIV(HLIEN)
.....I $D(DIV("ALL")) D
......S DIVISION=$$GET1^DIQ(4,HLIEN_",",.01)
......S:RET DIV("FOUND",HLIEN)=DIVISION
...I DIVISION="",'ORFND S LOCDIV=0
.I 'LOC!('LOCDIV) D
..N IEN
..S IEN=+$P($$SITE^VASITE(),U)
..S:'IEN IEN=+DUZ(2)
..Q:'IEN
..I $G(DIV("ALL"))="all divisions" D
...S DIVISION=$$GET1^DIQ(4,IEN_",",.01)
...S:RET DIV("FOUND",IEN)=DIVISION
..I '$D(DIV("ALL")),($D(DIV(IEN))) S DIVISION=DIV(IEN)
Q DIVISION
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORUTL 14362 printed Apr 09, 2024@21:35:23 Page 2
ORUTL ;SLC/DCM,RWF - ORDER UTILITIES ;11/02/2017 17:00
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**95,280,218,350,422,377**;Dec 17, 1997;Build 582
ISCLORD(ORY,ORIFN) ;;RPC to test if an order is a clinic order
+1 SET ORIFN=+ORIFN
+2 SET ORY=0
+3 IF 'ORIFN
QUIT
+4 NEW ORZ0
SET ORZ0=$GET(^OR(100,ORIFN,0))
+5 NEW ORTO
SET ORTO=$PIECE(ORZ0,U,11)
+6 IF ORTO=$$CLINMDDG
SET ORY=1
+7 IF ORTO=$$CLINIVDG
SET ORY=1
+8 QUIT
CLINMDDG() ;RETURN THE IEN OF THE CLINIC MEDICATIONS DISPLAY GROUP
+1 QUIT $ORDER(^ORD(100.98,"B","CLINIC MEDICATIONS",0))
CLINIVDG() ;RETURN THE IEN OF THE CLINIC INFUSIONS DISPLAY GROUP
+1 QUIT $ORDER(^ORD(100.98,"B","CLINIC INFUSIONS",0))
LOC ;;GET PT. LOCATION
+1 SET C(1)=$SELECT($DATA(ORL(2))#2:$SELECT(ORL(2)[";":$SELECT($DATA(@("^"_$PIECE(ORL(2),";",2)_+ORL(2)_",0)")):$PIECE(^(0),"^"),1:""),1:""),1:"")
+2 IF 'OR4
IF ORVP[";DPT("
IF $DATA(ORL(2))
IF ORL(2)
QUIT
+3 if $LENGTH(C(1))
GOTO LOC1
SET (CT,C)=0
SET O=1
IF ORVP[";DPT("
IF $ORDER(^DPT(+ORVP,"DE",0))>0
WRITE !!,"Currently enrolled in the following clinics: ",!
+4 IF $TEST
SET I=0
FOR L=0:0
SET I=$ORDER(^DPT(+ORVP,"DE",I))
if I'>0
QUIT
IF $DATA(^(I,0))
SET Y=^(0)
IF $PIECE(Y,"^",2)'="I"
IF '$PIECE(Y,"^",3)
IF $DATA(^SC(+Y,0))
SET X=^(0)
Begin DoDot:1
+5 IF $DATA(^SC(+Y,"I"))
SET ORIA=+^("I")
SET ORRA=$PIECE(^("I"),"^",2)
IF $SELECT('ORIA:0,ORIA>DT:0,ORRA'>DT&(ORRA):0,1:1)
QUIT
+6 SET CT=CT+1
if (CT#2)
WRITE !?17
if '(CT#2)
WRITE ?47
WRITE $PIECE(X,"^")
SET C=C+1
SET C(1)=$PIECE(X,"^")
if C'=1
SET C=-1
End DoDot:1
+7 WRITE !
LOC1 SET C=1
WRITE !,"Patient Location: "
if C=1&($LENGTH(C(1)))
WRITE C(1),"//"
READ X:DTIME
if '$TEST
GOTO QUIT
if C'=1&(X="")
GOTO QUIT
if $LENGTH(X)>20!(X'?.ANP)
GOTO LOC
if X[U
GOTO QUIT
+1 SET DIC("S")="I ""FI""'[$P(^(0),""^"",3),'$P($G(^(""OOS"")),""^"")"
SET DIC=44
SET DIC(0)=$SELECT(C=1&($LENGTH(C(1)))&(X=""):"EMQOZX",1:"EMQZ")
+2 if X=""
SET X=C(1)
DO ^DIC
if X["?"
GOTO LOC
if Y>0
SET ORL=+Y_";SC("
SET ORL(0)=$SELECT($LENGTH($PIECE(Y(0),"^",2)):$PIECE(Y(0),"^",2),1:$EXTRACT($PIECE(Y(0),"^"),1,4))
+3 KILL ORIA,ORRA
IF $DATA(^SC(+Y,"I"))
SET ORIA=+^("I")
SET ORRA=$PIECE(^("I"),U,2)
+4 IF $SELECT('$DATA(ORIA):0,'ORIA:0,ORIA>DT:0,ORRA'>DT&(ORRA):0,1:1)
WRITE $CHAR(7)," This location has been inactivated."
KILL ORL
GOTO LOC
+5 IF Y<0
WRITE " You must select a standard location."
GOTO LOC
+6 KILL DIC,C,ORIA,ORRA
QUIT
QUIT SET OREND=1
KILL DIC,C
QUIT
READ ;;Hold screen
+1 IF $DATA(IOST)
if $EXTRACT(IOST)'="C"
QUIT
+2 WRITE !
IF $DATA(IOSL)
IF $Y<(IOSL-4)
GOTO READ
+3 WRITE !?5,"Press return to continue "
READ X:$SELECT($DATA(DTIME):DTIME,1:300)
+4 QUIT
CHKNAM(X,Y) ;Input transform to not allow certain characters
+1 ;X is the text to be checked, Y are the characters not allowed as sent in by the input transform of the field
+2 ;if no special characters sent in, set list to all
NEW I,J
IF '$DATA(Y)
SET Y=";^"
+3 FOR I=1:1:$LENGTH(Y)
IF X[($EXTRACT(Y,I))
SET J=1
+4 QUIT +$GET(J)
CHKMNE(X) ;Input transform to not allow use of standard Lmgr Mnemonics
+1 NEW Y
+2 ;check to make sure mnemonic isn't set to lower case of restricted entries. List Manager is case insensitive
SET Y=$$UP^XLFSTR(X)
+3 IF Y="ADPL"!(Y="DN")!(Y="Q")!(Y="FS")!(Y="GO")!(Y="?")!(Y="??")!(Y="LS")!(Y="+")!(Y="-")!(Y="PL")!(Y="PS")!(Y="RD")!(Y="SL")!(Y="<")!(Y=">")!(Y="UP")!(Y="PI")!(Y="CWAD")!(Y="TD")!(Y="EX")
QUIT 1
+4 QUIT 0
PAD(ORX,ORL) ; Pads string to specified length
+1 NEW ORY
+2 SET ORY=""
SET $PIECE(ORY," ",(ORL-$LENGTH(ORX))+1)=""
+3 QUIT ORY
MAIL(XMTEXT,XMSUB,XMY,SUBSCR) ;SEND AN EMAIL
+1 ;PARAMETERS: XMTEXT => STRING CONTAINING NAME OF ARRAY CONTAINING MESSAGE TEXT (REQUIRED)
+2 ; XMSUB => STRING CONTAINING THE SUBJECT OF THE MESSAGE (REQUIRED)
+3 ; XMY => REFERENCE TO AN ARRAY CONTAINING THE RECIPIENTS (OPTIONAL)
+4 ; SUBSCR => STRING CONTAINING THE SUBSCIPT WITHIN ^XTMP WHERE RECIPIENTS ARE STORED (OPTIONAL)
+5 ;RETURN: $$MAIL => STRING CONTAINING XMMG (ERROR STRING)^XMERR (NUMBER OF ERRORS)
+6 NEW XMMG,XMDUZ,XMZ,XMERR,DIFROM,ORMSG
+7 if '$DATA(XMTEXT)!($GET(XMSUB)="")
QUIT
+8 IF $DATA(XMY)=0
Begin DoDot:1
+9 IF $GET(SUBSCR)'=""
IF ($QUERY(^XTMP(SUBSCR,0))[SUBSCR)
Begin DoDot:2
+10 KILL ^XTMP(SUBSCR,0)
+11 MERGE XMY=^XTMP(SUBSCR)
+12 KILL ^XTMP(SUBSCR)
End DoDot:2
QUIT
+13 IF $DATA(ZTQUEUED)>0
Begin DoDot:2
+14 SET XMY(DUZ)=""
End DoDot:2
+15 IF '$TEST
Begin DoDot:2
+16 SET ORMSG(1)=" "
+17 SET ORMSG(2)="Select the recipient(s) of the report below."
+18 DO MAILOUT(.ORMSG)
End DoDot:2
End DoDot:1
+19 ;FORCE SENDER TO BE POSTMASTER
SET XMDUZ="POSTMASTER"
+20 ;ICR #10070
DO ^XMD
+21 KILL ORMSG
+22 IF $DATA(XMMG)>0
Begin DoDot:1
+23 SET ORMSG(1)=" "
+24 SET ORMSG(2)="Unable to email the report:"
+25 SET ORMSG(3)=XMMG
+26 DO MAILOUT(.ORMSG)
End DoDot:1
+27 QUIT $GET(XMMG)_U_$GET(XMERR)
MAILOUT(MESSAGE) ;OUTPUT THE ORMSG ARRAY FROM MAIL LINE TAG
+1 ;IF KIDS IS NOT EXECUTING, OUTPUT THE MESSAGE TO THE SCREEN
+2 IF $GET(XPDNM)=""
Begin DoDot:1
+3 NEW LINE
SET LINE=0
FOR
SET LINE=$ORDER(MESSAGE(LINE))
if +$GET(LINE)=0
QUIT
WRITE MESSAGE(LINE),!
End DoDot:1
+4 IF '$TEST
DO MES^XPDUTL(.MESSAGE)
+5 QUIT
WRAP(ORLINE,OROUTPUT,ORDINDEN,ORTRIM,OROI,ORCNT,ORIOM,ORZERO) ;WRAP THE TEXT SO
+1 ; THAT IT IS NO MORE THAN X CHARACTERS WIDE
+2 ;PARAMETERS: ORLINE =>SINGLE LINE OF TEXT TO WRAP
+3 ; OROUTPUT=>NAME OF ARRAY THAT WILL STORE THE WRAPPED TEXT IN THE FORMAT:
+4 ; OROUTPUT=NUMBER OF LINES OF TEXT RETURNED
+5 ; OROUTPUT(N)=LINE N OF TEXT
+6 ; ORDINDEN=>FOR RETURNED TEXT, DETERMINE WHETHER TO INDENT LINES 2 THROUGH LAST (1) OR NOT (0)
+7 ; DEFAULT: 1
+8 ; ORTRIM =>FOR RETURNED TEXT, STRIP TRAILING SPACES ON EACH LINE (1) OR NOT (0)
+9 ; DEFAULT: 1
+10 ; OROI =>FOR RETURNED TEXT, THE COLUMN NUMBER TO INDENT LINES 2 THROUGH LAST TO
+11 ; DEFAULT: CALCULATE COLUMN TO INDENT TO
+12 ; ORCNT =>'$D(ORCNT) - RETURN NUMBER OF LINES IN RETURN ARRAY (OROUTPUT=N)
+13 ; $D(ORCNT)=1 - RETURN NUMBER OF LINES IN ORCNT
+14 ; ORIOM =>HOW WIDE EACH LINE SHOULD BE
+15 ; +ORIOM=0 - USES EITHER VALUE IN IOM OR 80
+16 ; ORZERO =>FOR RETURNED TEXT, RETURN TEXT IN A ZERO SUBSCRIPT DESCENDENT FROM THE LINE
+17 ; NUMBER SUBSCRIPT (1) OR NOT (0)
+18 ; DEFAULT: 0
+19 NEW ORRETURN,ORTEMP,ORINDENT,ORLCNT
+20 SET ORDINDEN=+$GET(ORDINDEN,1)
SET ORTRIM=+$GET(ORTRIM,1)
SET OROI=+$GET(OROI)
SET ORZERO=+$GET(ORZERO)
+21 IF $DATA(ORCNT)
SET ORLCNT=ORCNT
+22 IF $GET(@OROUTPUT)>0
SET ORLCNT=@OROUTPUT
+23 SET ORIOM=+$SELECT($GET(ORIOM)>0:ORIOM,$GET(IOM)>0:IOM,1:80)
+24 IF ORDINDEN
IF 'OROI
Begin DoDot:1
+25 NEW ORCHR
+26 IF ORLINE[":"
IF ($LENGTH($PIECE(ORLINE,":"))<ORIOM)
SET ORINDENT=$$REPEAT^XLFSTR(" ",$LENGTH($PIECE(ORLINE,":"))+2)
+27 IF ORLINE'[":"
IF ($EXTRACT(ORLINE,1)=" ")
Begin DoDot:2
+28 FOR ORCHR=1:1:$LENGTH(ORLINE)
if $EXTRACT(ORLINE,ORCHR)'=" "
QUIT
+29 SET ORINDENT=$$REPEAT^XLFSTR(" ",ORCHR-1)
End DoDot:2
+30 IF ORLINE'[":"
IF ($EXTRACT(ORLINE,1)'=" ")
Begin DoDot:2
+31 NEW START,END
+32 FOR ORCHR=1:1:$LENGTH(ORLINE)
if +$GET(END)
QUIT
Begin DoDot:3
+33 IF '+$GET(START)
IF ($EXTRACT(ORLINE,ORCHR)=" ")
IF ($EXTRACT(ORLINE,ORCHR+1)=" ")
SET START=1
+34 IF +$GET(START)
IF ($EXTRACT(ORLINE,ORCHR)'=" ")
SET END=1
End DoDot:3
+35 if +$GET(START)>0
SET ORINDENT=$$REPEAT^XLFSTR(" ",ORCHR-2)
End DoDot:2
End DoDot:1
+36 IF ORDINDEN
IF OROI>0
SET ORINDENT=$$REPEAT^XLFSTR(" ",OROI)
+37 SET ORTEMP=1
SET ORTEMP(ORTEMP)=ORLINE
+38 FOR
if $LENGTH(ORTEMP(ORTEMP))<(ORIOM+1)
QUIT
Begin DoDot:1
+39 NEW ORTEMP1,ORCHR
+40 FOR ORCHR=ORIOM:-1:1
if $EXTRACT(ORTEMP(ORTEMP),ORCHR)=" "
QUIT
+41 if ORCHR=1
SET ORCHR=ORIOM
+42 IF ORDINDEN
IF ORCHR=$LENGTH($GET(ORINDENT))
SET ORCHR=ORIOM
+43 SET ORTEMP1=ORTEMP(ORTEMP)
+44 SET ORTEMP(ORTEMP)=$EXTRACT(ORTEMP1,1,ORCHR)
+45 if ORTRIM
SET ORTEMP(ORTEMP)=$$TRIM^XLFSTR(ORTEMP(ORTEMP),"R")
+46 SET ORTEMP=ORTEMP+1
+47 SET ORTEMP(ORTEMP)=$GET(ORINDENT)_$EXTRACT(ORTEMP1,ORCHR+1,*)
End DoDot:1
+48 SET ORTEMP=0
FOR
SET ORTEMP=$ORDER(ORTEMP(ORTEMP))
if +ORTEMP=0
QUIT
Begin DoDot:1
+49 SET ORLCNT=1+$GET(ORLCNT)
+50 IF ORZERO
SET @OROUTPUT@(ORLCNT,0)=ORTEMP(ORTEMP)
+51 IF 'ORZERO
SET @OROUTPUT@(ORLCNT)=ORTEMP(ORTEMP)
End DoDot:1
+52 IF '$DATA(ORCNT)
SET @OROUTPUT=ORLCNT
+53 IF '$TEST
SET ORCNT=ORLCNT
+54 QUIT
DEVICE(ZTRTN,ZTDESC,%ZIS,ZTSAVE) ;PROMPT THE USER FOR THE OUTPUT DEVICE
+1 ;PARAMETERS: ZTRTN => LINE TAG THAT STARTS PRINTING THE REPORT
+2 ; ZTDESC => TASKMAN TASK DESCRIPTION
+3 ; %ZIS => FLAGS TO PASS TO ^%ZIS
+4 ; ZTSAVE => VARIABLES TO SAVE FOR TASKMAN
+5 NEW POP,CBUFFER
+6 SET %ZIS("B")=""
SET CBUFFER=0
+7 DO ^%ZIS
+8 if +$GET(POP)
QUIT
+9 IF $DATA(IO("Q"))
Begin DoDot:1
+10 NEW ZTSK,ORTEXT
+11 SET ORTEXT=$PIECE(ZTDESC,"OR ",2)
+12 SET ZTSAVE("CBUFFER")=""
+13 DO ^%ZTLOAD
DO HOME^%ZIS
+14 KILL IO("Q")
+15 IF +$GET(ZTSK)>0
WRITE !,"Successfully queued the "_ORTEXT_" report.",!,"Task Number: "_ZTSK,!
HANG 2
End DoDot:1
QUIT
+16 IF '$DATA(IO("Q"))
Begin DoDot:1
+17 USE IO
+18 IF $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
SET CBUFFER=3
+19 DO @ZTRTN
DO ^%ZISC
End DoDot:1
+20 QUIT
+1 ;PARAMETERS: TITLE => THE TITLE OF THE REPORT
+2 ; PAGE => (REFERENCE) PAGE NUMBER
+3 ; HEADER => (REFERENCE) COLUMN NAMES, FORMATTED AS:
+4 ; COLUMN(LINE_NUMBER)=TEXT
+5 ; NOTE: LINE_NUMBER STARTS AT ONE
+6 ; NEWRPT => (OPTIONAL) ALLOWS PRINTING OF MULTIPLE REPORTS
+7 ; ONE AFTER THE OTHER
+8 ; UNDEFINED: NOT PRINTING MULTIPLE REPORTS
+9 ; 0 (DEFAULT): THIS IS NOT THE START OF A
+10 ; NEW REPORT
+11 ; 1: THIS IS THE START OF A NEW REPORT
+12 ;RETURNS: 0 => USER WANTS TO CONTINUE PRINTING
+13 ; 1 => USER DOES NOT WANT TO CONTINUE PRINTING
+14 if $$STOPTASK
QUIT 1
+15 NEW X,END
+16 SET PAGE=1+$GET(PAGE)
+17 IF PAGE>1!(+$GET(NEWRPT))
Begin DoDot:1
+18 IF $EXTRACT(IOST,1,2)="C-"
WRITE !,"Press RETURN to continue or '^' to exit: "
READ X:DTIME
SET END='$TEST!(X=U)
if $GET(END)
QUIT
+19 IF $Y>0
IF $Y<=IOSL
WRITE @IOF
+20 IF $Y>IOSL
SET $Y=0
End DoDot:1
if $GET(END)
QUIT 1
+21 IF PAGE=1
IF ($EXTRACT(IOST,1,2)="C-")
IF ('+$GET(NEWRPT))
WRITE @IOF
+22 NEW NOW,INDEX
+23 SET NOW=$$UP^XLFSTR($$HTE^XLFDT($HOROLOG))
SET NOW=$PIECE(NOW,"@",1)_" "_$PIECE($PIECE(NOW,"@",2),":",1,2)
+24 WRITE $$LJ^XLFSTR($EXTRACT(TITLE,1,46),47," ")_NOW_" PAGE "_PAGE,!
+25 SET INDEX=0
FOR
SET INDEX=$ORDER(HEADER(INDEX))
if 'INDEX
QUIT
WRITE HEADER(INDEX),!
+26 WRITE $$REPEAT^XLFSTR("-",(IOM-1)),!
+27 QUIT 0
STOPTASK() ;DETERMINE IF TASKMAN HAS ASKED PROCESS TO STOP
+1 ;RETURNS: 0 => TASKMAN HAS NOT ASKED TASK TO STOP
+2 ; 1 => TASKMAN HAS ASKED TASK TO STOP
+3 IF $DATA(ZTQUEUED)
IF ($$S^%ZTLOAD)
Begin DoDot:1
+4 SET ZTSTOP=$$S^%ZTLOAD("Received stop request")
SET ZTSTOP=1
End DoDot:1
if $GET(ZTSTOP)=1
QUIT 1
+5 QUIT 0
FMERROR(ERROR) ;OUTPUT FILEMAN ERROR
+1 ;PARAMETERS: ERROR => (REFERENCE) ARRAY CONTAINING THE FILEMAN ERROR
+2 NEW OUT
+3 WRITE !!,"Unable to generate the report due to the following FileMan error:",!
+4 WRITE "FILEMAN ERROR #"_ERROR("DIERR",1)_":",!
+5 NEW IDX
SET IDX=""
FOR
SET IDX=$ORDER(ERROR("DIERR",1,"TEXT",IDX))
if 'IDX
QUIT
DO WRAP(ERROR("DIERR",1,"TEXT",IDX),"OUT")
+6 SET IDX=0
FOR
SET IDX=$ORDER(OUT(IDX))
if +$GET(IDX)=0
QUIT
WRITE OUT(IDX),!
+7 QUIT
DIVPRMPT(DIV) ;PROMPT THE USER FOR WHICH ACTIVE DIVISION(S)
+1 ;PARAMETERS: DIV => REFERENCE TO ARRAY WHICH WILL CONTAIN THE SELECTED DIVISION(S) WHEN THIS FINISHES
+2 ; FORMAT: DIV(FILE #4 IEN)=INSTITUTION NAME
+3 ; IF THE USER SELECTS ALL DIVISIONS, THEN ONLY THE FOLLOWING IS RETURNED:
+4 ; DIV("ALL")="all divisions"
+5 ;RETURNS: -1 USER ENTERED CARET AT PROMPT IF SITE IS MULTIDIVISIONAL
+6 ; 0 INSTITUTION FILE POINTER IS MISSING FOR ALL SELECTED DIVISIONS
+7 ; 1 SUCCESSFUL SELECTION OF DIVISION(S)
+8 NEW SELDIV,BADDIV,TIUDI,IDX,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,COUNT,DELIMIT
+9 FOR
Begin DoDot:1
+10 DO SELDIV^TIULA
+11 SET IDX=0
FOR
SET IDX=$ORDER(TIUDI(IDX))
if +$GET(IDX)=0
QUIT
Begin DoDot:2
+12 SET DIV(TIUDI(IDX))=$PIECE($$SITE^VASITE(,IDX),U,2)
SET COUNT=1+$GET(COUNT)
End DoDot:2
+13 IF SELDIV=1
IF ('$DATA(DIV))
SET DIV("ALL")="all divisions"
+14 IF $DATA(BADDIV)
Begin DoDot:2
+15 NEW TEXT,OUTPUT
+16 SET DELIMIT=", "
+17 FOR IDX=1:1:$LENGTH(BADDIV,",")
Begin DoDot:3
+18 if IDX=$LENGTH(BADDIV,",")
SET DELIMIT=" and "
+19 SET TEXT=$SELECT($GET(TEXT)'="":TEXT_DELIMIT,1:"")_$PIECE(BADDIV,",",IDX)
End DoDot:3
+20 SET BADDIV="I'm sorry, but "_TEXT_" "_$SELECT($LENGTH(BADDIV,",")=1:"is not a valid division.",$LENGTH(BADDIV,",")>1:"are not valid divisions.",1:"you selected an invalid division.")
+21 DO WRAP^ORUTL(BADDIV,"OUTPUT")
+22 WRITE !!
+23 FOR IDX=1:1:OUTPUT
WRITE OUTPUT(IDX),!
+24 IF $DATA(DIV)
Begin DoDot:3
+25 SET DIR(0)="Y"_U
SET DIR("A")="Do you want to continue with the valid division"_$SELECT(COUNT>1:"s",1:"")_" already selected"
+26 SET DIR("B")="YES"
+27 DO ^DIR
+28 if $DATA(DIRUT)
QUIT
+29 if Y
SET SELDIV=1
End DoDot:3
End DoDot:2
End DoDot:1
if +$GET(SELDIV)=1!(+$GET(SELDIV)=-1)
QUIT
+30 QUIT SELDIV
HASDIV(Y,DIV,RET) ;DETERMINE IF THE SPECIFIED USER BELONGS TO A SET OF DIVISIONS RETURNED BY DIVPRMPT^ORUTL
+1 ;PARAMETERS: Y => IEN IN THE NEW PERSON FILE (#200)
+2 ; DIV => REFERENCE TO ARRAY CONTAINING SELECTED DIVISIONS
+3 ; FORMAT: DIV(FILE_#4_IEN)=INSTITUTION NAME
+4 ; DIV("FOUND",FILE_#4_IEN)=INSTITUTION NAME <-- FOR DISCOVERED DIVISIONS
+5 ; RET => 1 TO RETURN DISCOVERED DIVISIONS IN DIV ARRAY, WHEN "ALL DIVISIONS" ARE SELECTED
+6 ; 0 TO NOT RETURN DISCOVERED DIVISIONS (DEFAULT)
+7 ;RETURNS: NAME OF Y'S DIVISION
+8 ; EMPTY STRING IF Y'S DIVISION IS NOT A SELECTED DIVISION
+9 NEW DIVISION
SET DIVISION=""
+10 SET RET=+$GET(RET)
+11 IF $DATA(DIV)
Begin DoDot:1
+12 NEW DIVISIONS,IDX,HASDIV
+13 ;IA #2533
+14 SET HASDIV=$$DIV4^XUSER(.DIVISIONS,Y)
+15 IF HASDIV=0
Begin DoDot:2
+16 NEW IEN
+17 SET IEN=$PIECE($$SITE^VASITE(),U)
+18 if +IEN=0
SET IEN=DUZ(2)
+19 SET DIVISIONS(IEN)=1
End DoDot:2
+20 IF $GET(DIV("ALL"))="all divisions"
Begin DoDot:2
+21 NEW IEN
+22 SET IEN=0
FOR
SET IEN=$ORDER(DIVISIONS(IEN))
if '+IEN
QUIT
Begin DoDot:3
+23 IF DIVISIONS(IEN)
Begin DoDot:4
+24 SET DIVISION=$$GET1^DIQ(4,IEN_",",.01)
+25 if RET
SET DIV("FOUND",IEN)=DIVISION
End DoDot:4
End DoDot:3
+26 IF DIVISION=""
Begin DoDot:3
+27 SET IEN=$ORDER(DIVISIONS(0))
SET DIVISION=$$GET1^DIQ(4,IEN_",",.01)
+28 if RET
SET DIV("FOUND",IEN)=DIVISION
End DoDot:3
End DoDot:2
QUIT
+29 SET IDX=0
FOR
SET IDX=$ORDER(DIVISIONS(IDX))
if +$GET(IDX)=0
QUIT
Begin DoDot:2
+30 IF $DATA(DIV(IDX))
Begin DoDot:3
+31 IF DIVISION'=""
IF (DIVISIONS(IDX)=1)
SET DIVISION=DIV(IDX)
+32 IF DIVISION=""
SET DIVISION=DIV(IDX)
End DoDot:3
End DoDot:2
End DoDot:1
+33 QUIT DIVISION
LHASDIV(LOC,DIV,RET) ;DETERMINE IF THE SPECIFIED LOCATION BELONGS TO A SET OF DIVISIONS RETURNED BY DIVPRMPT^ORUTL
+1 ;PARAMETERS: LOC => VARIABLE POINTER TO HOSPITAL LOCATION FILE (#44)
+2 ; DIV => REFERENCE TO ARRAY CONTAINING SELECTED DIVISIONS
+3 ; FORMAT: DIV(FILE_#4_IEN)=INSTITUTION NAME
+4 ; DIV("FOUND",FILE_#4_IEN)=INSTITUTION NAME <-- FOR DISCOVERED DIVISIONS
+5 ; RET => 1 TO RETURN DISCOVERED DIVISIONS IN DIV ARRAY, WHEN "ALL DIVISIONS" ARE SELECTED
+6 ; 0 TO NOT RETURN DISCOVERED DIVISIONS (DEFAULT)
+7 ;RETURNS: NAME OF LOC'S DIVISION
+8 ; EMPTY STRING IF LOC'S DIVISION IS NOT A SELECTED DIVISION
+9 NEW DIVISION,LOCDIV
+10 SET DIVISION=""
SET LOCDIV=0
SET LOC=$GET(LOC)
SET RET=+$GET(RET)
+11 IF $DATA(DIV)
Begin DoDot:1
+12 IF LOC>0
Begin DoDot:2
+13 NEW GLOREF,HLIEN
+14 SET GLOREF=U_$$UP^XLFSTR($PIECE(LOC,";",2))_+LOC_",0)"
+15 IF GLOREF'?1"^SC("1.N1",0)"
QUIT
+16 ;IA #10040
+17 SET LOCDIV=$PIECE($GET(@GLOREF),U,15)
+18 IF +LOCDIV
Begin DoDot:3
+19 NEW ORFND
+20 ;IA #2817
+21 SET ORFND=0
SET HLIEN=0
FOR
SET HLIEN=$ORDER(^DG(40.8,"AD",HLIEN))
if HLIEN=""
QUIT
Begin DoDot:4
+22 IF $DATA(^DG(40.8,"AD",HLIEN,LOCDIV))
Begin DoDot:5
+23 SET ORFND=1
+24 IF '$DATA(DIV("ALL"))
IF $DATA(DIV(HLIEN))
SET DIVISION=DIV(HLIEN)
+25 IF $DATA(DIV("ALL"))
Begin DoDot:6
+26 SET DIVISION=$$GET1^DIQ(4,HLIEN_",",.01)
+27 if RET
SET DIV("FOUND",HLIEN)=DIVISION
End DoDot:6
End DoDot:5
End DoDot:4
+28 IF DIVISION=""
IF 'ORFND
SET LOCDIV=0
End DoDot:3
End DoDot:2
+29 IF 'LOC!('LOCDIV)
Begin DoDot:2
+30 NEW IEN
+31 SET IEN=+$PIECE($$SITE^VASITE(),U)
+32 if 'IEN
SET IEN=+DUZ(2)
+33 if 'IEN
QUIT
+34 IF $GET(DIV("ALL"))="all divisions"
Begin DoDot:3
+35 SET DIVISION=$$GET1^DIQ(4,IEN_",",.01)
+36 if RET
SET DIV("FOUND",IEN)=DIVISION
End DoDot:3
+37 IF '$DATA(DIV("ALL"))
IF ($DATA(DIV(IEN)))
SET DIVISION=DIV(IEN)
End DoDot:2
End DoDot:1
+38 QUIT DIVISION
