ORU ; slc/dcm,JER - OE/RR Functions ;6/1/92 09:13
;;3.0;ORDER ENTRY/RESULTS REPORTING;**11,69**;Dec 17, 1997
UPPER(X) ; Convert lower case X to UPPER CASE
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
LOWER(X) ; Convert UPPER CASE X to lower case
Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
MIXED(X) ; Return Mixed Case X
N GMI,WORD,TMP
S TMP="" F GMI=1:1:$L(X," ") S WORD=$$UPPER($E($P(X," ",GMI)))_$$LOWER($E($P(X," ",GMI),2,$L($P(X," ",GMI)))),TMP=TMP_" "_WORD
Q TMP
INV() ;
N DX,DY
G:'$L($G(X))!($E(IOST)'="C") INVX
W:$Y>24 @IOF
W:$X>79 !
S DX=$X,DY=$Y
W @X
X ^%ZOSF("XY")
INVX ;
I $E(IOST)'="C",($L($G(X))) W:$Y'<IOSL @IOF W:$X>(IOM-1) ! W @X
Q ""
HON() ; High intensity on
I $E($G(IOST))="C",$D(ORTERM(7)),$L($P(ORTERM(7),"^")) W @$P(ORTERM(7),"^")
Q ""
HOFF() ; High intensity off
I $E($G(IOST))="C",$D(ORTERM(7)),$L($P(ORTERM(7),"^",3)) W @$P(ORTERM(7),"^",3)
Q ""
TIME(X,FMT) ; Recieves X as 2910419.01 and FMT=Return Format of time (HH:MM:SS).
N HR,MIN,SEC,ORI
I $S('$D(FMT):1,'$L(FMT):1,1:0) S FMT="HR:MIN"
S (HR,MIN,SEC)="",X=$P(X,".",2)
I '$L(X),FMT["HR" S FMT=$P(FMT,"HR")
I $L(X) S HR=$E(X,1,2)_$E("00",0,2-$L($E(X,1,2))),MIN=$E(X,3,4)_$E("00",0,2-$L($E(X,3,4))),SEC=$E(X,5,6)_$E("00",0,2-$L($E(X,5,6)))
F ORI="HR","MIN","SEC" S:FMT[ORI FMT=$P(FMT,ORI)_@ORI_$P(FMT,ORI,2)
Q FMT
DATE(X,FMT) ; Call with X=2910419.01 and FMT=Return Format of date ("MM/DD")
N AMTH,MM,CC,DD,YY,ORI
I +X'>0 S FMT="" G QDATE
I $S('$D(FMT):1,'$L(FMT):1,1:0) S FMT="MM/DD/CCYY"
S MM=$E(X,4,5),DD=$E(X,6,7),YY=$E(X,2,3),CC=17+$E(X)
S:FMT["AMTH" AMTH=$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+MM)
F ORI="AMTH","MM","DD","CC","YY" S:FMT[ORI FMT=$P(FMT,ORI)_@ORI_$P(FMT,ORI,2)
I FMT["HR" S FMT=$$TIME(X,FMT)
QDATE Q FMT
DATETIME(X,FMT) ;Gets date & time format
Q:'$G(X) ""
Q $$DATE(X,$S($L($G(FMT)):FMT,1:"MM/DD/CCYY HR:MIN"))
NAME(X,FMT) ; Call with X="LAST,FIRST MI", FMT=Return Format ("LAST, FI")
N ORLAST,ORLI,ORFIRST,ORFI,ORMI,ORI
I X']"" S FMT="" G NAMEX
I $S('$D(FMT):1,'$L(FMT):1,1:0) S FMT="LAST,FIRST MI"
S FMT=$$LOWER(FMT)
S ORLAST=$P(X,","),ORLI=$E(ORLAST),ORFIRST=$P(X,",",2),ORFI=$E(ORFIRST),ORMI=$S($P(ORFIRST," ",2,5)'="NMI":$P(ORFIRST," ",2,5),1:""),ORFIRST=$P(ORFIRST," ")
F ORI="last","li","first","fi","mi" I FMT[ORI S FMT=$P(FMT,ORI)_@("OR"_$$UPPER(ORI))_$P(FMT,ORI,2)
NAMEX Q FMT
SSN(X,FMT) ;Call with Unformatted SSN
I '$L(X) Q ""
S FMT=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,99)
Q FMT
SEX(X,FMT) ;Call with unformatted SEX
I '$L($G(X)) Q ""
S FMT=$S($E(X)="F":"Female",1:"Male")
Q FMT
AGE(X,FMT) ;Pass DOB to calc age
I '$G(X) Q ""
S FMT=$S($L(X)=7:DT-X\10000,1:"??")
Q FMT
DOB(X,FMT) ;Pass unformatted DOB
I '$G(X) Q ""
I $S('$D(FMT):1,'$L(FMT):1,1:0) S FMT="MM/DD/CCYY"
Q $$DATE(X,FMT)
WORD(OROOT,FMT) ; Call with X=Word Processing array root, FMT=Wrap Width
I '$L($G(OROOT)) Q ""
S:'$G(FMT) FMT=80
N X,DIWL,DIWF,ORI
S DIWL=2,DIWF="WRC"_FMT,ORI=0
F S ORI=$O(@OROOT@(ORI)) Q:ORI'>0 S X=@OROOT@(ORI,0) D ^DIWP
D ^DIWW
Q ""
TEXT(OROOT,FMT) ;Non DIWP version of WORD function
I '$L($G(OROOT)) Q ""
S:'$G(FMT) FMT=80
N X,ORI,ORTX,ORCL,ORINDX
S ORCL=$X,ORINDX=1,ORI=0
F S ORI=$O(@OROOT@(ORI)) Q:ORI'>0 S X=@OROOT@(ORI,0),X=$$FMT^ORPRS09(FMT,ORINDX,X)
F ORI=0:0 S ORI=$O(ORTX(ORI)) Q:'ORI D FEED Q:$G(OREND) W:ORI'=$O(ORTX(0))&(+ORI>0) ! W ?ORCL,ORTX(ORI)
I '$G(OREND),$G(ORPDAD),$D(ORIFN) D DAD
Q ""
TEXTWRAP(OROOT,FMT) ;Non DIWP Word function that really Raps!
I '$L($G(OROOT)) Q ""
S:'$G(FMT) FMT=80
N X,ORI,ORTX,ORCL,ORINDX
S ORCL=$X,ORINDX=0,ORI=0
F S ORI=$O(@OROOT@(ORI)) Q:ORI'>0 S X=@OROOT@(ORI,0),ORINDX=ORINDX+1,X=$$FMT^ORPRS09(FMT,ORINDX,X)
F ORI=0:0 S ORI=$O(ORTX(ORI)) Q:'ORI D FEED Q:$G(OREND) W:ORI'=$O(ORTX(0))&(+ORI>0) ! W ?ORCL,ORTX(ORI)
I '$G(OREND),$G(ORPDAD),$D(ORIFN) D DAD
Q ""
TMPWRAP(OROOT,FMT) ;Non DIWP text function that Raps for ^TMP arays
I '$L($G(OROOT)) Q ""
S:'$G(FMT) FMT=80
N X,ORI,ORTX,ORCL,ORINDX
S ORCL=$X,ORINDX=0,ORI=0
F S ORI=$O(@OROOT@(ORI)) Q:ORI'>0 S X=$S($L($G(@OROOT@(ORI))):@OROOT@(ORI),$L($G(@OROOT@(ORI,0))):@OROOT@(ORI,0),1:""),ORINDX=ORINDX+1,X=$$FMT^ORPRS09(FMT,ORINDX,X)
F ORI=0:0 S ORI=$O(ORTX(ORI)) Q:'ORI D FEED Q:$G(OREND) W:ORI'=$O(ORTX(0))&(+ORI>0) ! W ?ORCL,ORTX(ORI)
I '$G(OREND),$G(ORPDAD),$D(ORIFN) D DAD
Q ""
DAD ;
N I,ORDAD
I '$D(ORIOSL) S ORIOSL=$S($G(IOSL):IOSL,1:50)
S ORDAD=1
D PRT1^ORPRS03(ORIFN,FMT)
K ORPDAD ;Set by print code in file 100.22
Q
FEED ;Roomcheck
Q:$G(ORTEST)
I $Y+2<$S($G(ORIOSL):ORIOSL,1:IOSL) Q
I $G(ORFOOT) D Q
. W ?(IOM-15),"(continued...)"
. D FOOT^ORPR01(ORFOOT)
. I '$G(OREND),$G(ORHEAD) D HEAD^ORPR01(ORHEAD) W !,"(...continued)"
Q:$E(IOST)'="C"
D PGBRK^ORUHDR
W:'$D(ORTIT)&($G(ORIOF)]"") @ORIOF
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORU 4895 printed Dec 13, 2024@02:34:21 Page 2
ORU ; slc/dcm,JER - OE/RR Functions ;6/1/92 09:13
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**11,69**;Dec 17, 1997
UPPER(X) ; Convert lower case X to UPPER CASE
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
LOWER(X) ; Convert UPPER CASE X to lower case
+1 QUIT $TRANSLATE(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
MIXED(X) ; Return Mixed Case X
+1 NEW GMI,WORD,TMP
+2 SET TMP=""
FOR GMI=1:1:$LENGTH(X," ")
SET WORD=$$UPPER($EXTRACT($PIECE(X," ",GMI)))_$$LOWER($EXTRACT($PIECE(X," ",GMI),2,$LENGTH($PIECE(X," ",GMI))))
SET TMP=TMP_" "_WORD
+3 QUIT TMP
INV() ;
+1 NEW DX,DY
+2 if '$LENGTH($GET(X))!($EXTRACT(IOST)'="C")
GOTO INVX
+3 if $Y>24
WRITE @IOF
+4 if $X>79
WRITE !
+5 SET DX=$X
SET DY=$Y
+6 WRITE @X
+7 XECUTE ^%ZOSF("XY")
INVX ;
+1 IF $EXTRACT(IOST)'="C"
IF ($LENGTH($GET(X)))
if $Y'<IOSL
WRITE @IOF
if $X>(IOM-1)
WRITE !
WRITE @X
+2 QUIT ""
HON() ; High intensity on
+1 IF $EXTRACT($GET(IOST))="C"
IF $DATA(ORTERM(7))
IF $LENGTH($PIECE(ORTERM(7),"^"))
WRITE @$PIECE(ORTERM(7),"^")
+2 QUIT ""
HOFF() ; High intensity off
+1 IF $EXTRACT($GET(IOST))="C"
IF $DATA(ORTERM(7))
IF $LENGTH($PIECE(ORTERM(7),"^",3))
WRITE @$PIECE(ORTERM(7),"^",3)
+2 QUIT ""
TIME(X,FMT) ; Recieves X as 2910419.01 and FMT=Return Format of time (HH:MM:SS).
+1 NEW HR,MIN,SEC,ORI
+2 IF $SELECT('$DATA(FMT):1,'$LENGTH(FMT):1,1:0)
SET FMT="HR:MIN"
+3 SET (HR,MIN,SEC)=""
SET X=$PIECE(X,".",2)
+4 IF '$LENGTH(X)
IF FMT["HR"
SET FMT=$PIECE(FMT,"HR")
+5 IF $LENGTH(X)
SET HR=$EXTRACT(X,1,2)_$EXTRACT("00",0,2-$LENGTH($EXTRACT(X,1,2)))
SET MIN=$EXTRACT(X,3,4)_$EXTRACT("00",0,2-$LENGTH($EXTRACT(X,3,4)))
SET SEC=$EXTRACT(X,5,6)_$EXTRACT("00",0,2-$LENGTH($EXTRACT(X,5,6)))
+6 FOR ORI="HR","MIN","SEC"
if FMT[ORI
SET FMT=$PIECE(FMT,ORI)_@ORI_$PIECE(FMT,ORI,2)
+7 QUIT FMT
DATE(X,FMT) ; Call with X=2910419.01 and FMT=Return Format of date ("MM/DD")
+1 NEW AMTH,MM,CC,DD,YY,ORI
+2 IF +X'>0
SET FMT=""
GOTO QDATE
+3 IF $SELECT('$DATA(FMT):1,'$LENGTH(FMT):1,1:0)
SET FMT="MM/DD/CCYY"
+4 SET MM=$EXTRACT(X,4,5)
SET DD=$EXTRACT(X,6,7)
SET YY=$EXTRACT(X,2,3)
SET CC=17+$EXTRACT(X)
+5 if FMT["AMTH"
SET AMTH=$PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+MM)
+6 FOR ORI="AMTH","MM","DD","CC","YY"
if FMT[ORI
SET FMT=$PIECE(FMT,ORI)_@ORI_$PIECE(FMT,ORI,2)
+7 IF FMT["HR"
SET FMT=$$TIME(X,FMT)
QDATE QUIT FMT
DATETIME(X,FMT) ;Gets date & time format
+1 if '$GET(X)
QUIT ""
+2 QUIT $$DATE(X,$SELECT($LENGTH($GET(FMT)):FMT,1:"MM/DD/CCYY HR:MIN"))
NAME(X,FMT) ; Call with X="LAST,FIRST MI", FMT=Return Format ("LAST, FI")
+1 NEW ORLAST,ORLI,ORFIRST,ORFI,ORMI,ORI
+2 IF X']""
SET FMT=""
GOTO NAMEX
+3 IF $SELECT('$DATA(FMT):1,'$LENGTH(FMT):1,1:0)
SET FMT="LAST,FIRST MI"
+4 SET FMT=$$LOWER(FMT)
+5 SET ORLAST=$PIECE(X,",")
SET ORLI=$EXTRACT(ORLAST)
SET ORFIRST=$PIECE(X,",",2)
SET ORFI=$EXTRACT(ORFIRST)
SET ORMI=$SELECT($PIECE(ORFIRST," ",2,5)'="NMI":$PIECE(ORFIRST," ",2,5),1:"")
SET ORFIRST=$PIECE(ORFIRST," ")
+6 FOR ORI="last","li","first","fi","mi"
IF FMT[ORI
SET FMT=$PIECE(FMT,ORI)_@("OR"_$$UPPER(ORI))_$PIECE(FMT,ORI,2)
NAMEX QUIT FMT
SSN(X,FMT) ;Call with Unformatted SSN
+1 IF '$LENGTH(X)
QUIT ""
+2 SET FMT=$EXTRACT(X,1,3)_"-"_$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,99)
+3 QUIT FMT
SEX(X,FMT) ;Call with unformatted SEX
+1 IF '$LENGTH($GET(X))
QUIT ""
+2 SET FMT=$SELECT($EXTRACT(X)="F":"Female",1:"Male")
+3 QUIT FMT
AGE(X,FMT) ;Pass DOB to calc age
+1 IF '$GET(X)
QUIT ""
+2 SET FMT=$SELECT($LENGTH(X)=7:DT-X\10000,1:"??")
+3 QUIT FMT
DOB(X,FMT) ;Pass unformatted DOB
+1 IF '$GET(X)
QUIT ""
+2 IF $SELECT('$DATA(FMT):1,'$LENGTH(FMT):1,1:0)
SET FMT="MM/DD/CCYY"
+3 QUIT $$DATE(X,FMT)
WORD(OROOT,FMT) ; Call with X=Word Processing array root, FMT=Wrap Width
+1 IF '$LENGTH($GET(OROOT))
QUIT ""
+2 if '$GET(FMT)
SET FMT=80
+3 NEW X,DIWL,DIWF,ORI
+4 SET DIWL=2
SET DIWF="WRC"_FMT
SET ORI=0
+5 FOR
SET ORI=$ORDER(@OROOT@(ORI))
if ORI'>0
QUIT
SET X=@OROOT@(ORI,0)
DO ^DIWP
+6 DO ^DIWW
+7 QUIT ""
TEXT(OROOT,FMT) ;Non DIWP version of WORD function
+1 IF '$LENGTH($GET(OROOT))
QUIT ""
+2 if '$GET(FMT)
SET FMT=80
+3 NEW X,ORI,ORTX,ORCL,ORINDX
+4 SET ORCL=$X
SET ORINDX=1
SET ORI=0
+5 FOR
SET ORI=$ORDER(@OROOT@(ORI))
if ORI'>0
QUIT
SET X=@OROOT@(ORI,0)
SET X=$$FMT^ORPRS09(FMT,ORINDX,X)
+6 FOR ORI=0:0
SET ORI=$ORDER(ORTX(ORI))
if 'ORI
QUIT
DO FEED
if $GET(OREND)
QUIT
if ORI'=$ORDER(ORTX(0))&(+ORI>0)
WRITE !
WRITE ?ORCL,ORTX(ORI)
+7 IF '$GET(OREND)
IF $GET(ORPDAD)
IF $DATA(ORIFN)
DO DAD
+8 QUIT ""
TEXTWRAP(OROOT,FMT) ;Non DIWP Word function that really Raps!
+1 IF '$LENGTH($GET(OROOT))
QUIT ""
+2 if '$GET(FMT)
SET FMT=80
+3 NEW X,ORI,ORTX,ORCL,ORINDX
+4 SET ORCL=$X
SET ORINDX=0
SET ORI=0
+5 FOR
SET ORI=$ORDER(@OROOT@(ORI))
if ORI'>0
QUIT
SET X=@OROOT@(ORI,0)
SET ORINDX=ORINDX+1
SET X=$$FMT^ORPRS09(FMT,ORINDX,X)
+6 FOR ORI=0:0
SET ORI=$ORDER(ORTX(ORI))
if 'ORI
QUIT
DO FEED
if $GET(OREND)
QUIT
if ORI'=$ORDER(ORTX(0))&(+ORI>0)
WRITE !
WRITE ?ORCL,ORTX(ORI)
+7 IF '$GET(OREND)
IF $GET(ORPDAD)
IF $DATA(ORIFN)
DO DAD
+8 QUIT ""
TMPWRAP(OROOT,FMT) ;Non DIWP text function that Raps for ^TMP arays
+1 IF '$LENGTH($GET(OROOT))
QUIT ""
+2 if '$GET(FMT)
SET FMT=80
+3 NEW X,ORI,ORTX,ORCL,ORINDX
+4 SET ORCL=$X
SET ORINDX=0
SET ORI=0
+5 FOR
SET ORI=$ORDER(@OROOT@(ORI))
if ORI'>0
QUIT
SET X=$SELECT($LENGTH($GET(@OROOT@(ORI))):@OROOT@(ORI),$LENGTH($GET(@OROOT@(ORI,0))):@OROOT@(ORI,0),1:"")
SET ORINDX=ORINDX+1
SET X=$$FMT^ORPRS09(FMT,ORINDX,X)
+6 FOR ORI=0:0
SET ORI=$ORDER(ORTX(ORI))
if 'ORI
QUIT
DO FEED
if $GET(OREND)
QUIT
if ORI'=$ORDER(ORTX(0))&(+ORI>0)
WRITE !
WRITE ?ORCL,ORTX(ORI)
+7 IF '$GET(OREND)
IF $GET(ORPDAD)
IF $DATA(ORIFN)
DO DAD
+8 QUIT ""
DAD ;
+1 NEW I,ORDAD
+2 IF '$DATA(ORIOSL)
SET ORIOSL=$SELECT($GET(IOSL):IOSL,1:50)
+3 SET ORDAD=1
+4 DO PRT1^ORPRS03(ORIFN,FMT)
+5 ;Set by print code in file 100.22
KILL ORPDAD
+6 QUIT
FEED ;Roomcheck
+1 if $GET(ORTEST)
QUIT
+2 IF $Y+2<$SELECT($GET(ORIOSL):ORIOSL,1:IOSL)
QUIT
+3 IF $GET(ORFOOT)
Begin DoDot:1
+4 WRITE ?(IOM-15),"(continued...)"
+5 DO FOOT^ORPR01(ORFOOT)
+6 IF '$GET(OREND)
IF $GET(ORHEAD)
DO HEAD^ORPR01(ORHEAD)
WRITE !,"(...continued)"
End DoDot:1
QUIT
+7 if $EXTRACT(IOST)'="C"
QUIT
+8 DO PGBRK^ORUHDR
+9 if '$DATA(ORTIT)&($GET(ORIOF)]"")
WRITE @ORIOF
+10 QUIT
