RGRSUTL2 ;ALB/RJS-UTILITIES FOR CIRN ;1/2/97
;;1.0; CLINICAL INFO RESOURCE NETWORK ;;30 Apr 99
;
SSN(SSN,ARRAY) ;RETURNS DFN'S OF ALL SSN'S OR PSUEDO'S THAT MATCH
; THE SSN PASSED
; CALLING ROUTINE MUST KILL ARRAY BEFORE CALLING THIS
; FUNCTION
Q:$G(SSN)=""!($G(ARRAY)="")
N RGDFN S RGDFN=0
F S RGDFN=$O(^DPT("SSN",SSN,RGDFN)) Q:RGDFN'>0 D SET(RGDFN)
I $D(@ARRAY) Q 1
Q 0
SET(DFN) ;
Q:'$D(^DPT(DFN,0))
S @ARRAY@(DFN)=$P(^DPT(DFN,0),"^",1)
Q
; This function determines if a word is singular or plural and also
; determines if "no" or a numeric value is placed in front of
; the word (ie no exception(s)).
SNGPLR(RGNUM,RGSNG,RGPLR) ;
N RGZ
S RGZ=RGSNG?.E1L.E,RGPLR=$G(RGPLR,RGSNG_$S(RGZ:"s",1:"S"))
Q $S('RGNUM:$S(RGZ:"no ",1:"NO ")_RGPLR,RGNUM=1:"1 "_RGSNG,1:RGNUM_" "_RGPLR)
; Display formatted title
TITLE(RGTTL,RGVER,RGFN) ;
I '$D(IOM) N IOM,IOF S IOM=80,IOF="#"
S RGVER=$G(RGVER,"1.0")
S:RGVER RGVER="Version "_RGVER
U $G(IO,$I)
W @IOF,$S(IO=IO(0):$C(27,91,55,109),1:""),$C(13)
S Y=$$DT^XLFDT X ^DD("DD")
W Y,?(IOM-$L(RGTTL)\2),RGTTL,?(IOM-$L(RGVER)),RGVER,!,$S(IO=IO(0):$C(27,91,109),1:$$UND),!
W:$D(RGFN) ?(IOM-$L(RGFN)\2),RGFN,!
Q
; Pause for user response
PAUSE(RGP,RGX,RGY) ;
Q $$GETCH($G(RGP,"Press RETURN or ENTER to continue..."),U,.RGX,.RGY)
; Single character read
GETCH(RGP,RGV,RGX,RGY,RGT,RGD) ;
N RGZ,RGC
W:$D(RGX)!$D(RGY) $$XY($G(RGX,$X),$G(RGY,$Y))
W $G(RGP)
S RGT=$G(RGT,$G(DTIME,999999999999)),RGD=$G(RGD,U),RGC=""
S:$D(RGV) RGV=$$UP^XLFSTR(RGV)_U
F D Q:'$L(RGZ)
.S RGZ=$$READ^XGF(1,RGT)
.E S RGC=RGD Q
.W $C(8)
.Q:'$L(RGZ)
.S RGZ=$$UP^XLFSTR(RGZ)
.I $D(RGV) D
..I RGV[RGZ S RGC=RGZ
..E W $C(7,32,8) S RGC=""
.E S RGC=RGZ
W !
Q RGC
; Convert X to base Y padded to length L
BASE(X,Y,L) ;
Q:(Y<2)!(Y>62) ""
N RGZ,RGZ1
S RGZ1="",X=$S(X<0:-X,1:X)
F S RGZ=X#Y,X=X\Y,RGZ1=$C($S(RGZ<10:RGZ+48,RGZ<36:RGZ+55,1:RGZ+61))_RGZ1 Q:'X
Q $S('$G(L):RGZ1,1:$$REPEAT^XLFSTR(0,L-$L(RGZ1))_$E(RGZ1,1,L))
;
; Output an underline X bytes long
UND(X) Q $$REPEAT^XLFSTR("-",$G(X,$G(IOM,80)))
;
; Position cursor
XY(DX,DY) ;
D:$G(IOXY)="" HOME^%ZIS
S DX=$S(+$G(DX)>0:+DX,1:0),DY=$S(+$G(DY)>0:+DY,1:0),$X=0
X IOXY
S $X=DX,$Y=DY
; Send an alert.
; XQAMSG = Message to send
; RGUSR = A semicolon-delimited list of users to receive alert.
ALERT(XQAMSG,RGUSR) ;
N XQA,XQAOPT,XQAFLG,XQAROU,XQADATA,XQAID
S @$$TRAP^RGZOSF("EXIT^RGRSUTL2"),RGUSR=$G(RGUSR,"*"),XQAMSG=$TR(XQAMSG,U,"~")
D ENTRY(RGUSR,.XQA),SETUP^XQALERT:$D(XQA)
EXIT Q
; Takes a list of receipients as input and produces an array of
; DUZ's as output.
; Inputs:
; RGUSR = Semicolon-delimited list of recipients
; RGLST = Special token list
; Outputs:
; RGOUT = Local array to receive DUZ list
ENTRY(RGUSR,RGOUT,RGLST) ;
N RGZ,RGZ1,RGZ2
K RGOUT
F RGZ=1:1:$L(RGUSR,";") S RGZ1=$P(RGUSR,";",RGZ) D:RGZ1'="" S:RGZ1 RGOUT(+RGZ1)=""
.S:$D(RGLST(RGZ1)) RGZ1=RGLST(RGZ1)
.Q:RGZ1?.N
.I RGZ1?1"-"1.N D MGRP(-RGZ1) S RGZ1=0 Q
.S RGZ2=$E(RGZ1,1,2)
.I RGZ2="G." D MGRP($E(RGZ1,3,999)) Q
.I RGZ2="L." D LIST($E(RGZ1,3,999)) Q
.S RGZ1=$$LKP(RGZ1)
Q
LKP(RGNAME) ;
N RGZ,RGZ1
I $D(^VA(200,"B",RGNAME)) S RGZ=RGNAME G L1
S RGZ=$O(^(RGNAME)),RGZ1=$O(^(RGZ))
Q:(RGZ="")!(RGNAME'=$E(RGZ,1,$L(RGNAME))) 0
Q:(RGZ1'="")&(RGNAME=$E(RGZ1,1,$L(RGNAME))) 0
L1 S RGZ1=$O(^(RGZ,0)),RGZ=$O(^(RGZ1))
Q:'RGZ1!RGZ 0
Q RGZ1
; Send a mail message.
MAIL(RGMSG,XMY,XMSUB,XMDUZ) ;
N XMTEXT
S:$D(RGMSG)=1 RGMSG(1)=RGMSG
S XMTEXT="RGMSG(",@$$TRAP^RGZOSF("EXIT^RGRSUTL2"),XMY=$G(XMY)
S:$G(XMSUB)="" XMSUB=RGMSG
S:$G(XMDUZ)="" XMDUZ=$G(DUZ)
F Q:'$L(XMY) S X=$P(XMY,";"),XMY=$P(XMY,";",2,999) S:$L(X) XMY(X)=""
D ^XMD:$D(XMY)>9
Q
LIST(RGLIST) ;
Q:RGLIST=""
S:RGLIST'=+RGLIST RGLIST=+$O(^RGCDSS(993.6,"B",RGLIST,0))
S @$$TRAP^RGZOSF("LERR^RGUTUSR")
X:$D(^RGCDSS(993.6,RGLIST,1)) ^(1)
LERR Q
MGRP(RGMGRP) ;
N RGX
S RGX(0)=""
D MGRP2(RGMGRP)
Q
MGRP2(RGMGRP) ;
N RGZ,RGZ1
Q:RGMGRP=""
S:RGMGRP'=+RGMGRP RGMGRP=+$O(^XMB(3.8,"B",RGMGRP,0))
Q:$D(RGX(RGMGRP))
S RGX(RGMGRP)=""
F RGZ=0:0 S RGZ=+$O(^XMB(3.8,RGMGRP,1,RGZ)) Q:'RGZ S RGOUT(+^(RGZ,0))=""
F RGZ=0:0 S RGZ=+$O(^XMB(3.8,RGMGRP,5,RGZ)) Q:'RGZ D MGRP2(^(RGZ,0))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRGRSUTL2 4332 printed Apr 09, 2024@20:47:06 Page 2
RGRSUTL2 ;ALB/RJS-UTILITIES FOR CIRN ;1/2/97
+1 ;;1.0; CLINICAL INFO RESOURCE NETWORK ;;30 Apr 99
+2 ;
SSN(SSN,ARRAY) ;RETURNS DFN'S OF ALL SSN'S OR PSUEDO'S THAT MATCH
+1 ; THE SSN PASSED
+2 ; CALLING ROUTINE MUST KILL ARRAY BEFORE CALLING THIS
+3 ; FUNCTION
+4 if $GET(SSN)=""!($GET(ARRAY)="")
QUIT
+5 NEW RGDFN
SET RGDFN=0
+6 FOR
SET RGDFN=$ORDER(^DPT("SSN",SSN,RGDFN))
if RGDFN'>0
QUIT
DO SET(RGDFN)
+7 IF $DATA(@ARRAY)
QUIT 1
+8 QUIT 0
SET(DFN) ;
+1 if '$DATA(^DPT(DFN,0))
QUIT
+2 SET @ARRAY@(DFN)=$PIECE(^DPT(DFN,0),"^",1)
+3 QUIT
+4 ; This function determines if a word is singular or plural and also
+5 ; determines if "no" or a numeric value is placed in front of
+6 ; the word (ie no exception(s)).
SNGPLR(RGNUM,RGSNG,RGPLR) ;
+1 NEW RGZ
+2 SET RGZ=RGSNG?.E1L.E
SET RGPLR=$GET(RGPLR,RGSNG_$SELECT(RGZ:"s",1:"S"))
+3 QUIT $SELECT('RGNUM:$SELECT(RGZ:"no ",1:"NO ")_RGPLR,RGNUM=1:"1 "_RGSNG,1:RGNUM_" "_RGPLR)
+4 ; Display formatted title
TITLE(RGTTL,RGVER,RGFN) ;
+1 IF '$DATA(IOM)
NEW IOM,IOF
SET IOM=80
SET IOF="#"
+2 SET RGVER=$GET(RGVER,"1.0")
+3 if RGVER
SET RGVER="Version "_RGVER
+4 USE $GET(IO,$IO)
+5 WRITE @IOF,$SELECT(IO=IO(0):$CHAR(27,91,55,109),1:""),$CHAR(13)
+6 SET Y=$$DT^XLFDT
XECUTE ^DD("DD")
+7 WRITE Y,?(IOM-$LENGTH(RGTTL)\2),RGTTL,?(IOM-$LENGTH(RGVER)),RGVER,!,$SELECT(IO=IO(0):$CHAR(27,91,109),1:$$UND),!
+8 if $DATA(RGFN)
WRITE ?(IOM-$LENGTH(RGFN)\2),RGFN,!
+9 QUIT
+10 ; Pause for user response
PAUSE(RGP,RGX,RGY) ;
+1 QUIT $$GETCH($GET(RGP,"Press RETURN or ENTER to continue..."),U,.RGX,.RGY)
+2 ; Single character read
GETCH(RGP,RGV,RGX,RGY,RGT,RGD) ;
+1 NEW RGZ,RGC
+2 if $DATA(RGX)!$DATA(RGY)
WRITE $$XY($GET(RGX,$X),$GET(RGY,$Y))
+3 WRITE $GET(RGP)
+4 SET RGT=$GET(RGT,$GET(DTIME,999999999999))
SET RGD=$GET(RGD,U)
SET RGC=""
+5 if $DATA(RGV)
SET RGV=$$UP^XLFSTR(RGV)_U
+6 FOR
Begin DoDot:1
+7 SET RGZ=$$READ^XGF(1,RGT)
+8 IF '$TEST
SET RGC=RGD
QUIT
+9 WRITE $CHAR(8)
+10 if '$LENGTH(RGZ)
QUIT
+11 SET RGZ=$$UP^XLFSTR(RGZ)
+12 IF $DATA(RGV)
Begin DoDot:2
+13 IF RGV[RGZ
SET RGC=RGZ
+14 IF '$TEST
WRITE $CHAR(7,32,8)
SET RGC=""
End DoDot:2
+15 IF '$TEST
SET RGC=RGZ
End DoDot:1
if '$LENGTH(RGZ)
QUIT
+16 WRITE !
+17 QUIT RGC
+18 ; Convert X to base Y padded to length L
BASE(X,Y,L) ;
+1 if (Y<2)!(Y>62)
QUIT ""
+2 NEW RGZ,RGZ1
+3 SET RGZ1=""
SET X=$SELECT(X<0:-X,1:X)
+4 FOR
SET RGZ=X#Y
SET X=X\Y
SET RGZ1=$CHAR($SELECT(RGZ<10:RGZ+48,RGZ<36:RGZ+55,1:RGZ+61))_RGZ1
if 'X
QUIT
+5 QUIT $SELECT('$GET(L):RGZ1,1:$$REPEAT^XLFSTR(0,L-$LENGTH(RGZ1))_$EXTRACT(RGZ1,1,L))
+6 ;
+7 ; Output an underline X bytes long
UND(X) QUIT $$REPEAT^XLFSTR("-",$GET(X,$GET(IOM,80)))
+1 ;
+2 ; Position cursor
XY(DX,DY) ;
+1 if $GET(IOXY)=""
DO HOME^%ZIS
+2 SET DX=$SELECT(+$GET(DX)>0:+DX,1:0)
SET DY=$SELECT(+$GET(DY)>0:+DY,1:0)
SET $X=0
+3 XECUTE IOXY
+4 SET $X=DX
SET $Y=DY
+5 ; Send an alert.
+6 ; XQAMSG = Message to send
+7 ; RGUSR = A semicolon-delimited list of users to receive alert.
ALERT(XQAMSG,RGUSR) ;
+1 NEW XQA,XQAOPT,XQAFLG,XQAROU,XQADATA,XQAID
+2 SET @$$TRAP^RGZOSF("EXIT^RGRSUTL2")
SET RGUSR=$GET(RGUSR,"*")
SET XQAMSG=$TRANSLATE(XQAMSG,U,"~")
+3 DO ENTRY(RGUSR,.XQA)
if $DATA(XQA)
DO SETUP^XQALERT
EXIT QUIT
+1 ; Takes a list of receipients as input and produces an array of
+2 ; DUZ's as output.
+3 ; Inputs:
+4 ; RGUSR = Semicolon-delimited list of recipients
+5 ; RGLST = Special token list
+6 ; Outputs:
+7 ; RGOUT = Local array to receive DUZ list
ENTRY(RGUSR,RGOUT,RGLST) ;
+1 NEW RGZ,RGZ1,RGZ2
+2 KILL RGOUT
+3 FOR RGZ=1:1:$LENGTH(RGUSR,";")
SET RGZ1=$PIECE(RGUSR,";",RGZ)
if RGZ1'=""
Begin DoDot:1
+4 if $DATA(RGLST(RGZ1))
SET RGZ1=RGLST(RGZ1)
+5 if RGZ1?.N
QUIT
+6 IF RGZ1?1"-"1.N
DO MGRP(-RGZ1)
SET RGZ1=0
QUIT
+7 SET RGZ2=$EXTRACT(RGZ1,1,2)
+8 IF RGZ2="G."
DO MGRP($EXTRACT(RGZ1,3,999))
QUIT
+9 IF RGZ2="L."
DO LIST($EXTRACT(RGZ1,3,999))
QUIT
+10 SET RGZ1=$$LKP(RGZ1)
End DoDot:1
if RGZ1
SET RGOUT(+RGZ1)=""
+11 QUIT
LKP(RGNAME) ;
+1 NEW RGZ,RGZ1
+2 IF $DATA(^VA(200,"B",RGNAME))
SET RGZ=RGNAME
GOTO L1
+3 SET RGZ=$ORDER(^(RGNAME))
SET RGZ1=$ORDER(^(RGZ))
+4 if (RGZ="")!(RGNAME'=$EXTRACT(RGZ,1,$LENGTH(RGNAME)))
QUIT 0
+5 if (RGZ1'="")&(RGNAME=$EXTRACT(RGZ1,1,$LENGTH(RGNAME)))
QUIT 0
L1 SET RGZ1=$ORDER(^(RGZ,0))
SET RGZ=$ORDER(^(RGZ1))
+1 if 'RGZ1!RGZ
QUIT 0
+2 QUIT RGZ1
+3 ; Send a mail message.
MAIL(RGMSG,XMY,XMSUB,XMDUZ) ;
+1 NEW XMTEXT
+2 if $DATA(RGMSG)=1
SET RGMSG(1)=RGMSG
+3 SET XMTEXT="RGMSG("
SET @$$TRAP^RGZOSF("EXIT^RGRSUTL2")
SET XMY=$GET(XMY)
+4 if $GET(XMSUB)=""
SET XMSUB=RGMSG
+5 if $GET(XMDUZ)=""
SET XMDUZ=$GET(DUZ)
+6 FOR
if '$LENGTH(XMY)
QUIT
SET X=$PIECE(XMY,";")
SET XMY=$PIECE(XMY,";",2,999)
if $LENGTH(X)
SET XMY(X)=""
+7 if $DATA(XMY)>9
DO ^XMD
+8 QUIT
LIST(RGLIST) ;
+1 if RGLIST=""
QUIT
+2 if RGLIST'=+RGLIST
SET RGLIST=+$ORDER(^RGCDSS(993.6,"B",RGLIST,0))
+3 SET @$$TRAP^RGZOSF("LERR^RGUTUSR")
+4 if $DATA(^RGCDSS(993.6,RGLIST,1))
XECUTE ^(1)
LERR QUIT
MGRP(RGMGRP) ;
+1 NEW RGX
+2 SET RGX(0)=""
+3 DO MGRP2(RGMGRP)
+4 QUIT
MGRP2(RGMGRP) ;
+1 NEW RGZ,RGZ1
+2 if RGMGRP=""
QUIT
+3 if RGMGRP'=+RGMGRP
SET RGMGRP=+$ORDER(^XMB(3.8,"B",RGMGRP,0))
+4 if $DATA(RGX(RGMGRP))
QUIT
+5 SET RGX(RGMGRP)=""
+6 FOR RGZ=0:0
SET RGZ=+$ORDER(^XMB(3.8,RGMGRP,1,RGZ))
if 'RGZ
QUIT
SET RGOUT(+^(RGZ,0))=""
+7 FOR RGZ=0:0
SET RGZ=+$ORDER(^XMB(3.8,RGMGRP,5,RGZ))
if 'RGZ
QUIT
DO MGRP2(^(RGZ,0))
+8 QUIT
