SROESAD1 ;BIR/ADM - SURGERY E-SIG UTILITY ; [ 04/16/01 1:03 PM ]
;;3.0;Surgery;**100,127,177**;24 Jun 93;Build 89
;
;** NOTICE: This routine is part of an implementation of a nationally
;** controlled procedure. Local modifications to this routine
;** are prohibited.
;
N SRALN,SRE,SRE1,SRFILE,SRFLD,SRG,SRI,SRJ,SRLN,SRMULT,SRNM,SRNUM,SRPF,SRPRE,SRS,SRSUB,SRTITLE,SRVAL,SRVAL1,SRVAL2,SRX,SRY,X
F SRJ="SRADDEND","SRAD1","SRAD2","SRADM1","SRADM2" K ^TMP(SRJ,$J,SRTN)
S SRI=0,SRG=$NA(^TMP("SRADDEND",$J,SRTN)) K @SRG
D GET^SROESAD
SING ; single fields
S SRFLD="" F S SRFLD=$O(^TMP("SRAD1",$J,SRTN,130,SRFLD)) Q:SRFLD="" D
.S SRTITLE=$P(SRFLD,"-"),X=$P(SRFLD,"-",2),SRFILE=$P(X,","),SRNUM=$P(X,",",2) I SRNUM[";W" D WPS Q
.S SRVAL1="<NOT ENTERED>",SRY=$G(^TMP("SRAD1",$J,SRTN,130,SRFLD)) I SRY'="" D EXT S SRVAL1=SRX
.S SRVAL2="<DELETED>",SRY=$G(^TMP("SRAD2",$J,SRTN,130,SRFLD)) I SRY'="" D EXT S SRVAL2=SRX
.D LINE(2) S @SRG@(SRI)="The "_SRTITLE_" field was changed" D LINE(1) S @SRG@(SRI)=" from "_SRVAL1 D LINE(1) S @SRG@(SRI)=" to "_SRVAL2
MULT ; multiples
S SRMULT="" F S SRMULT=$O(^TMP("SRADM1",$J,SRTN,SRMULT)) Q:SRMULT="" D
.D LINE(2) S @SRG@(SRI)="The "_SRMULT_" subfile was changed as follows:"
.S SRE=0 F S SRE=$O(^TMP("SRADM1",$J,SRTN,SRMULT,SRE)) Q:'SRE D
..S SRE1="",SRJ=2,SRPF=0 F S SRE1=$O(^TMP("SRADM1",$J,SRTN,SRMULT,SRE,SRE1)) Q:SRE1="" D Q:SRE1=""
...S SRFLD="" F S SRFLD=$O(^TMP("SRADM1",$J,SRTN,SRMULT,SRE,SRE1,SRFLD)) Q:SRFLD="" D PROC Q:SRFLD=""
Q
WPS ; word-processing fields
D LINE(2) S @SRG@(SRI)="The "_SRTITLE_" field was changed" D LINE(1) S @SRG@(SRI)=" >> from original "_SRTITLE_" text:"
I '$O(^TMP("SRAD1",$J,SRTN,130,SRFLD,0)) S @SRG@(SRI)=@SRG@(SRI)_" <NO TEXT ENTERED>"
S SRLN=0 F S SRLN=$O(^TMP("SRAD1",$J,SRTN,130,SRFLD,SRLN)) Q:'SRLN S X=^TMP("SRAD1",$J,SRTN,130,SRFLD,SRLN) D LINE(1) S @SRG@(SRI)=" "_X
WPS2 D LINE(1) S @SRG@(SRI)=" >> to updated "_SRTITLE_" text:" I '$O(^TMP("SRAD2",$J,SRTN,130,SRFLD,0)) S @SRG@(SRI)=@SRG@(SRI)_" <TEXT DELETED>"
S SRLN=0 F S SRLN=$O(^TMP("SRAD2",$J,SRTN,130,SRFLD,SRLN)) Q:'SRLN S X=^TMP("SRAD2",$J,SRTN,130,SRFLD,SRLN) D LINE(1) S @SRG@(SRI)=" "_X
Q
EXT ; get external value
S SRX=$$EXTERNAL^DILFD(SRFILE,SRNUM,"",SRY)
I SRFILE=130 D Q
.I SRNUM=27,SRX'="" S SRX=$E(SRX,1,5) D CPT Q
.I SRNUM=66 D DIAG
I SRFILE=130.16,SRNUM=3,SRX'="" S SRX=$E(SRX,1,5) D CPT Q
I SRFILE=130.18,SRNUM=3 D DIAG
Q
DIAG S SRY=$$ICD^SROICD(SRTN,SRY),SRX=SRX_" "_$P(SRY,"^",4)
Q
CPT S X=$$CPT^ICPTCOD(SRX,$P($G(^SRF(SRTN,0)),"^",9)),SRX=SRX_" "_$P(X,"^",3)
Q
PROC S SRTITLE=$P(SRFLD,"-",2),X=$P(SRFLD,"-",3),SRFILE=$P(X,","),SRNUM=$P(X,",",2),SRJ=$P(SRFLD,"-",4) I SRNUM[";W" D WPM Q
S SRVAL1="",SRY=$G(^TMP("SRADM1",$J,SRTN,SRMULT,SRE,SRE1,SRFLD)) I SRY'="" D EXT S SRVAL1=SRX
S SRVAL2="",SRY=$G(^TMP("SRADM2",$J,SRTN,SRMULT,SRE,SRE1,SRFLD)) I SRY'="" D EXT S SRVAL2=SRX
I $P(SRFLD,"-")="01",SRVAL1=""!(SRVAL2="") D FP01 Q
I 'SRPF,$P(SRNUM,";")=.01,SRVAL1=""!(SRVAL2="") D FP01S Q
I SRPF D FPX Q
S:SRVAL1="" SRVAL1="<NOT ENTERED>" S:SRVAL2="" SRVAL2="<DELETED>"
I SRVAL2=SRVAL1 D:$P(SRFLD,"-")="01" LINE(1) D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ)_"The "_SRTITLE_" entry "_SRVAL1_" was changed:" Q
D:$P(SRFLD,"-")="01" LINE(1) D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ)_"The "_SRTITLE_" field was changed" D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ)_" from "_SRVAL1 D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ)_" to "_SRVAL2
Q
FP01S ; add or delete subfile entry
I SRVAL1="" D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ)_"The following "_SRTITLE_" was ADDED:" S SRNM=2
I SRVAL2="" D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ)_"The following "_SRTITLE_" was DELETED:" S SRNM=1
S SRPF=1,SRVAL=$S(SRNM=1:SRVAL1,1:SRVAL2) D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ+2)_SRTITLE_": "_SRVAL
Q
FP01 ; add or delete
I SRVAL1="" D LINE(2) S @SRG@(SRI)=$$SPACE(SRJ)_"The following "_SRTITLE_" was ADDED:" S SRNM=2
I SRVAL2="" D LINE(2) S @SRG@(SRI)=$$SPACE(SRJ)_"The following "_SRTITLE_" was DELETED:" S SRNM=1
S SRPF=1,SRVAL=$S(SRNM=1:SRVAL1,1:SRVAL2) D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ+2)_SRTITLE_": "_SRVAL
Q
FPX S SRJ=SRJ+2 I SRNUM[";W" D WPM
S SRVAL="",SRY=$G(^TMP("SRADM"_SRNM,$J,SRTN,SRMULT,SRE,SRE1,SRFLD)) I SRY'="" D EXT S SRVAL=SRX
D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ)_SRTITLE_": "_SRVAL
Q
FWPM ; word-processing in multiples in added or deleted entries
I '$O(^TMP("SRAD1",$J,SRTN,SRMULT,SRE,SRE1,SRFLD,0)) S SRS=2
I '$O(^TMP("SRAD2",$J,SRTN,SRMULT,SRE,SRE1,SRFLD,0)) S SRS=1
D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ)_SRTITLE_":" S SRLN=0
F S SRLN=$O(^TMP("SRADM"_SRS,$J,SRTN,SRMULT,SRE,SRE1,SRFLD,SRLN)) Q:'SRLN S X=^TMP("SRADM"_SRS,$J,SRTN,SRMULT,SRE,SRE1,SRFLD,SRLN) D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ)_X
Q
WPM ; word-processing in multiples
I SRPF S SRJ=SRJ+2 D FWPM Q
D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ)_"The "_SRTITLE_" field was changed" D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ+2)_">> from original "_SRTITLE_" text:"
I '$O(^TMP("SRAD1",$J,SRTN,SRMULT,SRE,SRE1,SRFLD,0)) S @SRG@(SRI)=@SRG@(SRI)_" <NO TEXT ENTERED>" D WPM2 Q
S SRLN=0 F S SRLN=$O(^TMP("SRADM1",$J,SRTN,SRMULT,SRE,SRE1,SRFLD,SRLN)) Q:'SRLN S X=^TMP("SRADM1",$J,SRTN,SRMULT,SRE,SRE1,SRFLD,SRLN) D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ+2)_X
WPM2 D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ+2)_">> to updated "_SRTITLE_" text:" I '$O(^TMP("SRAD2",$J,SRTN,SRMULT,SRE,SRE1,SRFLD,0)) S @SRG@(SRI)=@SRG@(SRI)_" <TEXT DELETED>" Q
S SRLN=0 F S SRLN=$O(^TMP("SRADM2",$J,SRTN,SRMULT,SRE,SRE1,SRFLD,SRLN)) Q:'SRLN S X=^TMP("SRADM2",$J,SRTN,SRMULT,SRE,SRE1,SRFLD,SRLN) D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ+2)_X
Q
SPACE(NUM) ; create spaces
; pass in position, returns number of needed spaces
I '$D(@SRG@(SRI)) S @SRG@(SRI)=""
Q $J("",NUM-$L(@SRG@(SRI)))
Q
LINE(NUM) ; create carriage returns
F J=1:1:NUM S SRI=SRI+1,@SRG@(SRI)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROESAD1 5875 printed Dec 13, 2024@02:43:24 Page 2
SROESAD1 ;BIR/ADM - SURGERY E-SIG UTILITY ; [ 04/16/01 1:03 PM ]
+1 ;;3.0;Surgery;**100,127,177**;24 Jun 93;Build 89
+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 NEW SRALN,SRE,SRE1,SRFILE,SRFLD,SRG,SRI,SRJ,SRLN,SRMULT,SRNM,SRNUM,SRPF,SRPRE,SRS,SRSUB,SRTITLE,SRVAL,SRVAL1,SRVAL2,SRX,SRY,X
+8 FOR SRJ="SRADDEND","SRAD1","SRAD2","SRADM1","SRADM2"
KILL ^TMP(SRJ,$JOB,SRTN)
+9 SET SRI=0
SET SRG=$NAME(^TMP("SRADDEND",$JOB,SRTN))
KILL @SRG
+10 DO GET^SROESAD
SING ; single fields
+1 SET SRFLD=""
FOR
SET SRFLD=$ORDER(^TMP("SRAD1",$JOB,SRTN,130,SRFLD))
if SRFLD=""
QUIT
Begin DoDot:1
+2 SET SRTITLE=$PIECE(SRFLD,"-")
SET X=$PIECE(SRFLD,"-",2)
SET SRFILE=$PIECE(X,",")
SET SRNUM=$PIECE(X,",",2)
IF SRNUM[";W"
DO WPS
QUIT
+3 SET SRVAL1="<NOT ENTERED>"
SET SRY=$GET(^TMP("SRAD1",$JOB,SRTN,130,SRFLD))
IF SRY'=""
DO EXT
SET SRVAL1=SRX
+4 SET SRVAL2="<DELETED>"
SET SRY=$GET(^TMP("SRAD2",$JOB,SRTN,130,SRFLD))
IF SRY'=""
DO EXT
SET SRVAL2=SRX
+5 DO LINE(2)
SET @SRG@(SRI)="The "_SRTITLE_" field was changed"
DO LINE(1)
SET @SRG@(SRI)=" from "_SRVAL1
DO LINE(1)
SET @SRG@(SRI)=" to "_SRVAL2
End DoDot:1
MULT ; multiples
+1 SET SRMULT=""
FOR
SET SRMULT=$ORDER(^TMP("SRADM1",$JOB,SRTN,SRMULT))
if SRMULT=""
QUIT
Begin DoDot:1
+2 DO LINE(2)
SET @SRG@(SRI)="The "_SRMULT_" subfile was changed as follows:"
+3 SET SRE=0
FOR
SET SRE=$ORDER(^TMP("SRADM1",$JOB,SRTN,SRMULT,SRE))
if 'SRE
QUIT
Begin DoDot:2
+4 SET SRE1=""
SET SRJ=2
SET SRPF=0
FOR
SET SRE1=$ORDER(^TMP("SRADM1",$JOB,SRTN,SRMULT,SRE,SRE1))
if SRE1=""
QUIT
Begin DoDot:3
+5 SET SRFLD=""
FOR
SET SRFLD=$ORDER(^TMP("SRADM1",$JOB,SRTN,SRMULT,SRE,SRE1,SRFLD))
if SRFLD=""
QUIT
DO PROC
if SRFLD=""
QUIT
End DoDot:3
if SRE1=""
QUIT
End DoDot:2
End DoDot:1
+6 QUIT
WPS ; word-processing fields
+1 DO LINE(2)
SET @SRG@(SRI)="The "_SRTITLE_" field was changed"
DO LINE(1)
SET @SRG@(SRI)=" >> from original "_SRTITLE_" text:"
+2 IF '$ORDER(^TMP("SRAD1",$JOB,SRTN,130,SRFLD,0))
SET @SRG@(SRI)=@SRG@(SRI)_" <NO TEXT ENTERED>"
+3 SET SRLN=0
FOR
SET SRLN=$ORDER(^TMP("SRAD1",$JOB,SRTN,130,SRFLD,SRLN))
if 'SRLN
QUIT
SET X=^TMP("SRAD1",$JOB,SRTN,130,SRFLD,SRLN)
DO LINE(1)
SET @SRG@(SRI)=" "_X
WPS2 DO LINE(1)
SET @SRG@(SRI)=" >> to updated "_SRTITLE_" text:"
IF '$ORDER(^TMP("SRAD2",$JOB,SRTN,130,SRFLD,0))
SET @SRG@(SRI)=@SRG@(SRI)_" <TEXT DELETED>"
+1 SET SRLN=0
FOR
SET SRLN=$ORDER(^TMP("SRAD2",$JOB,SRTN,130,SRFLD,SRLN))
if 'SRLN
QUIT
SET X=^TMP("SRAD2",$JOB,SRTN,130,SRFLD,SRLN)
DO LINE(1)
SET @SRG@(SRI)=" "_X
+2 QUIT
EXT ; get external value
+1 SET SRX=$$EXTERNAL^DILFD(SRFILE,SRNUM,"",SRY)
+2 IF SRFILE=130
Begin DoDot:1
+3 IF SRNUM=27
IF SRX'=""
SET SRX=$EXTRACT(SRX,1,5)
DO CPT
QUIT
+4 IF SRNUM=66
DO DIAG
End DoDot:1
QUIT
+5 IF SRFILE=130.16
IF SRNUM=3
IF SRX'=""
SET SRX=$EXTRACT(SRX,1,5)
DO CPT
QUIT
+6 IF SRFILE=130.18
IF SRNUM=3
DO DIAG
+7 QUIT
DIAG SET SRY=$$ICD^SROICD(SRTN,SRY)
SET SRX=SRX_" "_$PIECE(SRY,"^",4)
+1 QUIT
CPT SET X=$$CPT^ICPTCOD(SRX,$PIECE($GET(^SRF(SRTN,0)),"^",9))
SET SRX=SRX_" "_$PIECE(X,"^",3)
+1 QUIT
PROC SET SRTITLE=$PIECE(SRFLD,"-",2)
SET X=$PIECE(SRFLD,"-",3)
SET SRFILE=$PIECE(X,",")
SET SRNUM=$PIECE(X,",",2)
SET SRJ=$PIECE(SRFLD,"-",4)
IF SRNUM[";W"
DO WPM
QUIT
+1 SET SRVAL1=""
SET SRY=$GET(^TMP("SRADM1",$JOB,SRTN,SRMULT,SRE,SRE1,SRFLD))
IF SRY'=""
DO EXT
SET SRVAL1=SRX
+2 SET SRVAL2=""
SET SRY=$GET(^TMP("SRADM2",$JOB,SRTN,SRMULT,SRE,SRE1,SRFLD))
IF SRY'=""
DO EXT
SET SRVAL2=SRX
+3 IF $PIECE(SRFLD,"-")="01"
IF SRVAL1=""!(SRVAL2="")
DO FP01
QUIT
+4 IF 'SRPF
IF $PIECE(SRNUM,";")=.01
IF SRVAL1=""!(SRVAL2="")
DO FP01S
QUIT
+5 IF SRPF
DO FPX
QUIT
+6 if SRVAL1=""
SET SRVAL1="<NOT ENTERED>"
if SRVAL2=""
SET SRVAL2="<DELETED>"
+7 IF SRVAL2=SRVAL1
if $PIECE(SRFLD,"-")="01"
DO LINE(1)
DO LINE(1)
SET @SRG@(SRI)=$$SPACE(SRJ)_"The "_SRTITLE_" entry "_SRVAL1_" was changed:"
QUIT
+8 if $PIECE(SRFLD,"-")="01"
DO LINE(1)
DO LINE(1)
SET @SRG@(SRI)=$$SPACE(SRJ)_"The "_SRTITLE_" field was changed"
DO LINE(1)
SET @SRG@(SRI)=$$SPACE(SRJ)_" from "_SRVAL1
DO LINE(1)
SET @SRG@(SRI)=$$SPACE(SRJ)_" to "_SRVAL2
+9 QUIT
FP01S ; add or delete subfile entry
+1 IF SRVAL1=""
DO LINE(1)
SET @SRG@(SRI)=$$SPACE(SRJ)_"The following "_SRTITLE_" was ADDED:"
SET SRNM=2
+2 IF SRVAL2=""
DO LINE(1)
SET @SRG@(SRI)=$$SPACE(SRJ)_"The following "_SRTITLE_" was DELETED:"
SET SRNM=1
+3 SET SRPF=1
SET SRVAL=$SELECT(SRNM=1:SRVAL1,1:SRVAL2)
DO LINE(1)
SET @SRG@(SRI)=$$SPACE(SRJ+2)_SRTITLE_": "_SRVAL
+4 QUIT
FP01 ; add or delete
+1 IF SRVAL1=""
DO LINE(2)
SET @SRG@(SRI)=$$SPACE(SRJ)_"The following "_SRTITLE_" was ADDED:"
SET SRNM=2
+2 IF SRVAL2=""
DO LINE(2)
SET @SRG@(SRI)=$$SPACE(SRJ)_"The following "_SRTITLE_" was DELETED:"
SET SRNM=1
+3 SET SRPF=1
SET SRVAL=$SELECT(SRNM=1:SRVAL1,1:SRVAL2)
DO LINE(1)
SET @SRG@(SRI)=$$SPACE(SRJ+2)_SRTITLE_": "_SRVAL
+4 QUIT
FPX SET SRJ=SRJ+2
IF SRNUM[";W"
DO WPM
+1 SET SRVAL=""
SET SRY=$GET(^TMP("SRADM"_SRNM,$JOB,SRTN,SRMULT,SRE,SRE1,SRFLD))
IF SRY'=""
DO EXT
SET SRVAL=SRX
+2 DO LINE(1)
SET @SRG@(SRI)=$$SPACE(SRJ)_SRTITLE_": "_SRVAL
+3 QUIT
FWPM ; word-processing in multiples in added or deleted entries
+1 IF '$ORDER(^TMP("SRAD1",$JOB,SRTN,SRMULT,SRE,SRE1,SRFLD,0))
SET SRS=2
+2 IF '$ORDER(^TMP("SRAD2",$JOB,SRTN,SRMULT,SRE,SRE1,SRFLD,0))
SET SRS=1
+3 DO LINE(1)
SET @SRG@(SRI)=$$SPACE(SRJ)_SRTITLE_":"
SET SRLN=0
+4 FOR
SET SRLN=$ORDER(^TMP("SRADM"_SRS,$JOB,SRTN,SRMULT,SRE,SRE1,SRFLD,SRLN))
if 'SRLN
QUIT
SET X=^TMP("SRADM"_SRS,$JOB,SRTN,SRMULT,SRE,SRE1,SRFLD,SRLN)
DO LINE(1)
SET @SRG@(SRI)=$$SPACE(SRJ)_X
+5 QUIT
WPM ; word-processing in multiples
+1 IF SRPF
SET SRJ=SRJ+2
DO FWPM
QUIT
+2 DO LINE(1)
SET @SRG@(SRI)=$$SPACE(SRJ)_"The "_SRTITLE_" field was changed"
DO LINE(1)
SET @SRG@(SRI)=$$SPACE(SRJ+2)_">> from original "_SRTITLE_" text:"
+3 IF '$ORDER(^TMP("SRAD1",$JOB,SRTN,SRMULT,SRE,SRE1,SRFLD,0))
SET @SRG@(SRI)=@SRG@(SRI)_" <NO TEXT ENTERED>"
DO WPM2
QUIT
+4 SET SRLN=0
FOR
SET SRLN=$ORDER(^TMP("SRADM1",$JOB,SRTN,SRMULT,SRE,SRE1,SRFLD,SRLN))
if 'SRLN
QUIT
SET X=^TMP("SRADM1",$JOB,SRTN,SRMULT,SRE,SRE1,SRFLD,SRLN)
DO LINE(1)
SET @SRG@(SRI)=$$SPACE(SRJ+2)_X
WPM2 DO LINE(1)
SET @SRG@(SRI)=$$SPACE(SRJ+2)_">> to updated "_SRTITLE_" text:"
IF '$ORDER(^TMP("SRAD2",$JOB,SRTN,SRMULT,SRE,SRE1,SRFLD,0))
SET @SRG@(SRI)=@SRG@(SRI)_" <TEXT DELETED>"
QUIT
+1 SET SRLN=0
FOR
SET SRLN=$ORDER(^TMP("SRADM2",$JOB,SRTN,SRMULT,SRE,SRE1,SRFLD,SRLN))
if 'SRLN
QUIT
SET X=^TMP("SRADM2",$JOB,SRTN,SRMULT,SRE,SRE1,SRFLD,SRLN)
DO LINE(1)
SET @SRG@(SRI)=$$SPACE(SRJ+2)_X
+2 QUIT
SPACE(NUM) ; create spaces
+1 ; pass in position, returns number of needed spaces
+2 IF '$DATA(@SRG@(SRI))
SET @SRG@(SRI)=""
+3 QUIT $JUSTIFY("",NUM-$LENGTH(@SRG@(SRI)))
+4 QUIT
LINE(NUM) ; create carriage returns
+1 FOR J=1:1:NUM
SET SRI=SRI+1
SET @SRG@(SRI)=""
+2 QUIT
