SROGMTS0 ;BIR/ADM - SURGERY HEALTH SUMMARY ; [ 02/18/04 7:12 AM ]
;;3.0; Surgery ;**100**;24 Jun 93
;
;** NOTICE: This routine is part of an implementation of a nationally
;** controlled procedure. Local modifications to this routine
;** are prohibited.
;
; Reference to TGET^TIUSRVR1 supported by DBIA #2944
;
Q
ED(X) ; external date
S X=$G(X) Q:'$L(X) ""
S X=$TR($$FMTE^XLFDT(X,"5DZ"),"@"," ")
Q X
EDT(X) ; external date and time
S X=$G(X) Q:'$L(X) ""
S X=$TR($$FMTE^XLFDT(X,"2ZM"),"@"," ")
Q X
EN(X) ; Convert Case
N Y,SROK,SROC,SRWORD,SRPC,SRLEAD,SRTLR,SRTR,SRCTR,SRPRE
S (SRTR,SRWORD,SRPC)="",X=$$UP(X)
; Parse by Spaces
F SRCTR=1:1:$L(X," ") D
. S SRWORD=$P(X," ",SRCTR)
. S (SRPC,SRLEAD,SRTLR)=""
. I $E(SRWORD,1)="(" S SRWORD=$E(SRWORD,2,$L(SRWORD)),SRLEAD="("
. I $E(SRWORD,$L(SRWORD))=")" S SRWORD=$E(SRWORD,1,($L(SRWORD)-1)),SRTLR=")"
. ; String contains special characters
. S SROK=1 F SROC="(",")","-","*","+","{","&","}","[","]","/","\","|",",","'" S:SRWORD[SROC SROK=0 Q:'SROK
. I 'SROK D SP
. I SROK D SRWORD
. S:SRLEAD'="" SRWORD=SRLEAD_SRWORD
. S:SRTLR'="" SRWORD=SRWORD_SRTLR
. S SRTR=SRTR_" "_SRWORD
S X=$$TRIM(SRTR) Q X
EN2(X) ; Convert Case 2
S X=$$CK($$EN($G(X))) Q X
SP ; Special Characters
; Special Cases of Special Characters
I $$UP(SRWORD)="W/&W/O" S SRWORD="w/&w/o" Q
I $$UP(SRWORD)="W&W/O" S SRWORD="w&w/o" Q
I $$UP(SRWORD)="&/OR" S SRWORD="&/or" Q
I SRWORD="W/O" S SRWORD="w/o" Q
N SROK,SRWD1,SRWD2,SRW,SRWCTR,SRCHR
S SRWD1=SRWORD,SRWD2="",SRW=""
F SRWCTR=1:1:$L(SRWD1) D
. S SRCHR=$E(SRWD1,SRWCTR) I "()-*+{}'&[]/\|,"[SRCHR,$L(SRW) D Q
. . S SRPRE=""
. . S:$E(SRW,1,2)="ZZ"&($L(SRW)>2) SRPRE="ZZ",SRW=$E(SRW,3,$L(SRW))
. . S SRW=SRPRE_$$CASE(SRW,SRCHR)
. . S SRWD2=SRWD2_SRW_SRCHR,SRW=""
. S SRW=SRW_SRCHR
I $L(SRW) D
. N SRPSN F SRPSN=1:1:$L(SRW) Q:"()-*+{}'&[]/\|,"'[$E(SRW,SRPSN)
. N SROW,SRLW S SRLW=$E(SRW,0,(SRPSN-1))
. S SROW=$E(SRW,SRPSN,$L(SRW))
. S SRPRE="" S:$E(SROW,1,2)="ZZ"&($L(SROW)>2) SRPRE="ZZ",SROW=$E(SROW,3,$L(SROW))
. S SROW=SRPRE_$$CASE(SROW,$E($G(SRWD2),$L($G(SRWD2))))
. S SRW=SRLW_SROW
. S SRWD2=SRWD2_SRW
S SRWORD=SRWD2 S:SRCTR=1 SRWORD=$$LD(SRWORD)
K SRWD1,SRWD2
Q
SRWORD ; Convert word
S SRPRE="" S:$E(SRWORD,1,2)="ZZ"&($L(SRWORD)>2) SRPRE="ZZ",SRWORD=$E(SRWORD,3,$L(SRWORD))
S SRWORD=SRPRE_$$CASE(SRWORD,"")
Q
CASE(X,J) ; Set to Mixed/lower/UPPER case
N SRTAG,SRRTN,Y S X=$$UP($G(X)),Y="",SRTAG=$L(X),SRRTN="SROGMTS1"
S:+SRTAG>4 SRRTN="SROGMTS2" S:+SRTAG>9 SRTAG="M"
Q:+SRTAG=0&(SRTAG'="M") X
S SRRTN=SRTAG_"^"_SRRTN D @SRRTN
I $L(Y) S X=Y Q X
S X=$$MX(X)
Q X
LO(X) Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
UP(X) Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
MX(X) Q $TR($E(X,1),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$TR($E(X,2,$L(X)),"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
LD(X) Q $TR($E(X,1),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$E(X,2,$L(X))
TRIM(X) S X=$G(X) F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
Q X
CK(X) ;
S X=$G(X)
F Q:X'["(S)" S X=$P(X,"(S)",1)_"(s)"_$P(X,"(S)",2,299)
F Q:X'[" A " S X=$P(X," A ",1)_" a "_$P(X," A ",2,229)
I X["Class a" F Q:X'["Class a" S X=$P(X,"Class a",1)_"Class A"_$P(X,"Class a",2,229)
I X["Type a" F Q:X'["Type a" S X=$P(X,"Type a",1)_"Type A"_$P(X,"Type a",2,229)
F Q:X'["'S" S X=$P(X,"'S",1)_"'s"_$P(X,"'S",2,229)
I X["mg Diet" F Q:X'["mg Diet" S X=$P(X,"mg Diet",1)_"MG Diet"_$P(X,"mg Diet",2,229)
I X["LO-Fat" F Q:X'["LO-Fat" S X=$P(X,"LO-Fat",1)_"Lo-Fat"_$P(X,"LO-Fat",2,229)
I $E(X,1)="'" S X="'"_$$LD($E(X,2,$L(X)))
S X=$TR($E(X,1),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$E(X,2,$L(X))
Q X
DICT ; get dictation from TIU completed
N SRCT,SRL,SRNON,SRSTAT,SRSUM,SRTIU,SRTN,SROY,SRT
S SRTN=IEN,SRNON=$S($P($G(^SRF(SRTN,"NON")),"^")="Y":1,1:0)
S (SRSTAT,SRSUM)="" D STATUS I SRSTAT=7 K ^TMP("SRLQ",$J) D
. S REC(130,SRTN,1.15,1)=SRSUM,REC(130,SRTN,1.15,2)="",SRCT=3
. D TGET^TIUSRVR1(.SROY,SRTIU,"VIEW")
. S SRT=0 F S SRT=$O(@SROY@(SRT)) Q:SRT="" D
. . I $D(@SROY@(SRT))=10 S REC(130,SRTN,1.15,SRCT)=@SROY@(SRT,0)
. . E S REC(130,SRTN,1.15,SRCT)=@SROY@(SRT)
. . S SRCT=SRCT+1
. K @SROY
Q
STATUS ; get status of summary in TIU
I 'SRNON D Q
.S SRTIU=$P($G(^SRF(SRTN,"TIU")),"^") I SRTIU S SRSTAT=$$STATUS^SROESUTL(SRTIU) D
..I SRSTAT=7 S SRSUM=" * * The Operation Report has been electronically signed. * *"
I SRNON D
.S SRTIU=$P($G(^SRF(SRTN,"TIU")),"^",3) I SRTIU S SRSTAT=$$STATUS^SROESUTL(SRTIU) D
..I SRSTAT=7 S SRSUM=" * * The Procedure Report (Non-OR) has been electronically signed. * *" Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROGMTS0 4817 printed Apr 09, 2024@21:40:50 Page 2
SROGMTS0 ;BIR/ADM - SURGERY HEALTH SUMMARY ; [ 02/18/04 7:12 AM ]
+1 ;;3.0; Surgery ;**100**;24 Jun 93
+2 ;
+3 ;** NOTICE: This routine is part of an implementation of a nationally
+4 ;** controlled procedure. Local modifications to this routine
+5 ;** are prohibited.
+6 ;
+7 ; Reference to TGET^TIUSRVR1 supported by DBIA #2944
+8 ;
+9 QUIT
ED(X) ; external date
+1 SET X=$GET(X)
if '$LENGTH(X)
QUIT ""
+2 SET X=$TRANSLATE($$FMTE^XLFDT(X,"5DZ"),"@"," ")
+3 QUIT X
EDT(X) ; external date and time
+1 SET X=$GET(X)
if '$LENGTH(X)
QUIT ""
+2 SET X=$TRANSLATE($$FMTE^XLFDT(X,"2ZM"),"@"," ")
+3 QUIT X
EN(X) ; Convert Case
+1 NEW Y,SROK,SROC,SRWORD,SRPC,SRLEAD,SRTLR,SRTR,SRCTR,SRPRE
+2 SET (SRTR,SRWORD,SRPC)=""
SET X=$$UP(X)
+3 ; Parse by Spaces
+4 FOR SRCTR=1:1:$LENGTH(X," ")
Begin DoDot:1
+5 SET SRWORD=$PIECE(X," ",SRCTR)
+6 SET (SRPC,SRLEAD,SRTLR)=""
+7 IF $EXTRACT(SRWORD,1)="("
SET SRWORD=$EXTRACT(SRWORD,2,$LENGTH(SRWORD))
SET SRLEAD="("
+8 IF $EXTRACT(SRWORD,$LENGTH(SRWORD))=")"
SET SRWORD=$EXTRACT(SRWORD,1,($LENGTH(SRWORD)-1))
SET SRTLR=")"
+9 ; String contains special characters
+10 SET SROK=1
FOR SROC="(",")","-","*","+","{","&","}","[","]","/","\","|",",","'"
if SRWORD[SROC
SET SROK=0
if 'SROK
QUIT
+11 IF 'SROK
DO SP
+12 IF SROK
DO SRWORD
+13 if SRLEAD'=""
SET SRWORD=SRLEAD_SRWORD
+14 if SRTLR'=""
SET SRWORD=SRWORD_SRTLR
+15 SET SRTR=SRTR_" "_SRWORD
End DoDot:1
+16 SET X=$$TRIM(SRTR)
QUIT X
EN2(X) ; Convert Case 2
+1 SET X=$$CK($$EN($GET(X)))
QUIT X
SP ; Special Characters
+1 ; Special Cases of Special Characters
+2 IF $$UP(SRWORD)="W/&W/O"
SET SRWORD="w/&w/o"
QUIT
+3 IF $$UP(SRWORD)="W&W/O"
SET SRWORD="w&w/o"
QUIT
+4 IF $$UP(SRWORD)="&/OR"
SET SRWORD="&/or"
QUIT
+5 IF SRWORD="W/O"
SET SRWORD="w/o"
QUIT
+6 NEW SROK,SRWD1,SRWD2,SRW,SRWCTR,SRCHR
+7 SET SRWD1=SRWORD
SET SRWD2=""
SET SRW=""
+8 FOR SRWCTR=1:1:$LENGTH(SRWD1)
Begin DoDot:1
+9 SET SRCHR=$EXTRACT(SRWD1,SRWCTR)
IF "()-*+{}'&[]/\|,"[SRCHR
IF $LENGTH(SRW)
Begin DoDot:2
+10 SET SRPRE=""
+11 if $EXTRACT(SRW,1,2)="ZZ"&($LENGTH(SRW)>2)
SET SRPRE="ZZ"
SET SRW=$EXTRACT(SRW,3,$LENGTH(SRW))
+12 SET SRW=SRPRE_$$CASE(SRW,SRCHR)
+13 SET SRWD2=SRWD2_SRW_SRCHR
SET SRW=""
End DoDot:2
QUIT
+14 SET SRW=SRW_SRCHR
End DoDot:1
+15 IF $LENGTH(SRW)
Begin DoDot:1
+16 NEW SRPSN
FOR SRPSN=1:1:$LENGTH(SRW)
if "()-*+{}'&[]/\|,"'[$EXTRACT(SRW,SRPSN)
QUIT
+17 NEW SROW,SRLW
SET SRLW=$EXTRACT(SRW,0,(SRPSN-1))
+18 SET SROW=$EXTRACT(SRW,SRPSN,$LENGTH(SRW))
+19 SET SRPRE=""
if $EXTRACT(SROW,1,2)="ZZ"&($LENGTH(SROW)>2)
SET SRPRE="ZZ"
SET SROW=$EXTRACT(SROW,3,$LENGTH(SROW))
+20 SET SROW=SRPRE_$$CASE(SROW,$EXTRACT($GET(SRWD2),$LENGTH($GET(SRWD2))))
+21 SET SRW=SRLW_SROW
+22 SET SRWD2=SRWD2_SRW
End DoDot:1
+23 SET SRWORD=SRWD2
if SRCTR=1
SET SRWORD=$$LD(SRWORD)
+24 KILL SRWD1,SRWD2
+25 QUIT
SRWORD ; Convert word
+1 SET SRPRE=""
if $EXTRACT(SRWORD,1,2)="ZZ"&($LENGTH(SRWORD)>2)
SET SRPRE="ZZ"
SET SRWORD=$EXTRACT(SRWORD,3,$LENGTH(SRWORD))
+2 SET SRWORD=SRPRE_$$CASE(SRWORD,"")
+3 QUIT
CASE(X,J) ; Set to Mixed/lower/UPPER case
+1 NEW SRTAG,SRRTN,Y
SET X=$$UP($GET(X))
SET Y=""
SET SRTAG=$LENGTH(X)
SET SRRTN="SROGMTS1"
+2 if +SRTAG>4
SET SRRTN="SROGMTS2"
if +SRTAG>9
SET SRTAG="M"
+3 if +SRTAG=0&(SRTAG'="M")
QUIT X
+4 SET SRRTN=SRTAG_"^"_SRRTN
DO @SRRTN
+5 IF $LENGTH(Y)
SET X=Y
QUIT X
+6 SET X=$$MX(X)
+7 QUIT X
LO(X) QUIT $TRANSLATE(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
UP(X) QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
MX(X) QUIT $TRANSLATE($EXTRACT(X,1),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$TRANSLATE($EXTRACT(X,2,$LENGTH(X)),"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
LD(X) QUIT $TRANSLATE($EXTRACT(X,1),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$EXTRACT(X,2,$LENGTH(X))
TRIM(X) SET X=$GET(X)
FOR
if $EXTRACT(X,1)'=" "
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+1 FOR
if $EXTRACT(X,$LENGTH(X))'=" "
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+2 QUIT X
CK(X) ;
+1 SET X=$GET(X)
+2 FOR
if X'["(S)"
QUIT
SET X=$PIECE(X,"(S)",1)_"(s)"_$PIECE(X,"(S)",2,299)
+3 FOR
if X'[" A "
QUIT
SET X=$PIECE(X," A ",1)_" a "_$PIECE(X," A ",2,229)
+4 IF X["Class a"
FOR
if X'["Class a"
QUIT
SET X=$PIECE(X,"Class a",1)_"Class A"_$PIECE(X,"Class a",2,229)
+5 IF X["Type a"
FOR
if X'["Type a"
QUIT
SET X=$PIECE(X,"Type a",1)_"Type A"_$PIECE(X,"Type a",2,229)
+6 FOR
if X'["'S"
QUIT
SET X=$PIECE(X,"'S",1)_"'s"_$PIECE(X,"'S",2,229)
+7 IF X["mg Diet"
FOR
if X'["mg Diet"
QUIT
SET X=$PIECE(X,"mg Diet",1)_"MG Diet"_$PIECE(X,"mg Diet",2,229)
+8 IF X["LO-Fat"
FOR
if X'["LO-Fat"
QUIT
SET X=$PIECE(X,"LO-Fat",1)_"Lo-Fat"_$PIECE(X,"LO-Fat",2,229)
+9 IF $EXTRACT(X,1)="'"
SET X="'"_$$LD($EXTRACT(X,2,$LENGTH(X)))
+10 SET X=$TRANSLATE($EXTRACT(X,1),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$EXTRACT(X,2,$LENGTH(X))
+11 QUIT X
DICT ; get dictation from TIU completed
+1 NEW SRCT,SRL,SRNON,SRSTAT,SRSUM,SRTIU,SRTN,SROY,SRT
+2 SET SRTN=IEN
SET SRNON=$SELECT($PIECE($GET(^SRF(SRTN,"NON")),"^")="Y":1,1:0)
+3 SET (SRSTAT,SRSUM)=""
DO STATUS
IF SRSTAT=7
KILL ^TMP("SRLQ",$JOB)
Begin DoDot:1
+4 SET REC(130,SRTN,1.15,1)=SRSUM
SET REC(130,SRTN,1.15,2)=""
SET SRCT=3
+5 DO TGET^TIUSRVR1(.SROY,SRTIU,"VIEW")
+6 SET SRT=0
FOR
SET SRT=$ORDER(@SROY@(SRT))
if SRT=""
QUIT
Begin DoDot:2
+7 IF $DATA(@SROY@(SRT))=10
SET REC(130,SRTN,1.15,SRCT)=@SROY@(SRT,0)
+8 IF '$TEST
SET REC(130,SRTN,1.15,SRCT)=@SROY@(SRT)
+9 SET SRCT=SRCT+1
End DoDot:2
+10 KILL @SROY
End DoDot:1
+11 QUIT
STATUS ; get status of summary in TIU
+1 IF 'SRNON
Begin DoDot:1
+2 SET SRTIU=$PIECE($GET(^SRF(SRTN,"TIU")),"^")
IF SRTIU
SET SRSTAT=$$STATUS^SROESUTL(SRTIU)
Begin DoDot:2
+3 IF SRSTAT=7
SET SRSUM=" * * The Operation Report has been electronically signed. * *"
End DoDot:2
End DoDot:1
QUIT
+4 IF SRNON
Begin DoDot:1
+5 SET SRTIU=$PIECE($GET(^SRF(SRTN,"TIU")),"^",3)
IF SRTIU
SET SRSTAT=$$STATUS^SROESUTL(SRTIU)
Begin DoDot:2
+6 IF SRSTAT=7
SET SRSUM=" * * The Procedure Report (Non-OR) has been electronically signed. * *"
QUIT
End DoDot:2
End DoDot:1
+7 QUIT
