source: FOIAVistA/tag/r/SURGERY-SR/SROESAR2.m@ 1607

Last change on this file since 1607 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 5.3 KB
Line 
1SROESAR2 ;BIR/ADM - ANESTHESIA REPORT E-SIG UTILITY ; [ 02/14/04 6:36 AM
2 ;;3.0; Surgery ;**100**;24 Jun 93
3 ;
4 ;** NOTICE: This routine is part of an implementation of a nationally
5 ;** controlled procedure. Local modifications to this routine
6 ;** are prohibited.
7 ;
8 N SRALN,SRE,SRE1,SRFILE,SRFLD,SRG,SRI,SRJ,SRLN,SRMULT,SRNM,SRNUM,SRPF,SRS,SRTITLE,SRVAL,SRVAL1,SRVAL2,SRX,SRY,X
9 S SRI=0,SRG=$NA(^TMP("SRAR",$J,SRTN)) K @SRG
10SING ; single fields
11 S SRFLD="" F S SRFLD=$O(^TMP("SRARAD1",$J,SRTN,130,SRFLD)) Q:SRFLD="" D
12 .S SRTITLE=$P(SRFLD,"-"),X=$P(SRFLD,"-",2),SRFILE=$P(X,","),SRNUM=$P(X,",",2) I SRNUM[";W" D WPS Q
13 .S SRVAL1="<NOT ENTERED>",SRY=$G(^TMP("SRARAD1",$J,SRTN,130,SRFLD)) I SRY'="" D EXT S SRVAL1=SRX
14 .S SRVAL2="<DELETED>",SRY=$G(^TMP("SRARAD2",$J,SRTN,130,SRFLD)) I SRY'="" D EXT S SRVAL2=SRX
15 .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
16MULT ; multiples
17 S SRMULT="" F S SRMULT=$O(^TMP("SRARMULT1",$J,SRTN,SRMULT)) Q:SRMULT="" D
18 .D LINE(2) S @SRG@(SRI)="The "_SRMULT_" subfile was changed as follows:"
19 .S SRE=0 F S SRE=$O(^TMP("SRARMULT1",$J,SRTN,SRMULT,SRE)) Q:'SRE D
20 ..S SRE1="",SRJ=2,SRPF=0 F S SRE1=$O(^TMP("SRARMULT1",$J,SRTN,SRMULT,SRE,SRE1)) Q:SRE1="" D Q:SRE1=""
21 ...S SRFLD="" F S SRFLD=$O(^TMP("SRARMULT1",$J,SRTN,SRMULT,SRE,SRE1,SRFLD)) Q:SRFLD="" D PROC Q:SRFLD=""
22 Q
23WPS ; word-processing fields
24 D LINE(2) S @SRG@(SRI)="The "_SRTITLE_" field was changed" D LINE(1) S @SRG@(SRI)=" >> from original "_SRTITLE_" text:"
25 I '$O(^TMP("SRARAD1",$J,SRTN,130,SRFLD,0)) S @SRG@(SRI)=@SRG@(SRI)_" <NO TEXT ENTERED>"
26 S SRLN=0 F S SRLN=$O(^TMP("SRARAD1",$J,SRTN,130,SRFLD,SRLN)) Q:'SRLN S X=^TMP("SRARAD1",$J,SRTN,130,SRFLD,SRLN) D LINE(1) S @SRG@(SRI)=" "_X
27WPS2 D LINE(1) S @SRG@(SRI)=" >> to updated "_SRTITLE_" text:" I '$O(^TMP("SRARAD2",$J,SRTN,130,SRFLD,0)) S @SRG@(SRI)=@SRG@(SRI)_" <TEXT DELETED>"
28 S SRLN=0 F S SRLN=$O(^TMP("SRARAD2",$J,SRTN,130,SRFLD,SRLN)) Q:'SRLN S X=^TMP("SRARAD2",$J,SRTN,130,SRFLD,SRLN) D LINE(1) S @SRG@(SRI)=" "_X
29 Q
30EXT ; get external value
31 S SRX=$$EXTERNAL^DILFD(SRFILE,SRNUM,"",SRY)
32 Q
33PROC 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
34 S SRVAL1="",SRY=$G(^TMP("SRARMULT1",$J,SRTN,SRMULT,SRE,SRE1,SRFLD)) I SRY'="" D EXT S SRVAL1=SRX
35 S SRVAL2="",SRY=$G(^TMP("SRARMULT2",$J,SRTN,SRMULT,SRE,SRE1,SRFLD)) I SRY'="" D EXT S SRVAL2=SRX
36 I $P(SRFLD,"-")="01",SRVAL1=""!(SRVAL2="") D FP01 Q
37 I 'SRPF,$P(SRNUM,";")=.01,SRVAL1=""!(SRVAL2="") D FP01S Q
38 I SRPF D FPX Q
39 S:SRVAL1="" SRVAL1="<NOT ENTERED>" S:SRVAL2="" SRVAL2="<DELETED>"
40 I SRVAL2=SRVAL1 D:$P(SRFLD,"-")="01" LINE(1) D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ)_"The "_SRTITLE_" entry "_SRVAL1_" was changed:" Q
41 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
42 Q
43FP01S ; add or delete subfile entry
44 I SRVAL1="" D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ)_"The following "_SRTITLE_" was ADDED:" S SRNM=2
45 I SRVAL2="" D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ)_"The following "_SRTITLE_" was DELETED:" S SRNM=1
46 S SRPF=1,SRVAL=$S(SRNM=1:SRVAL1,1:SRVAL2) D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ+2)_SRTITLE_": "_SRVAL
47 Q
48FP01 ; add or delete
49 I SRVAL1="" D LINE(2) S @SRG@(SRI)=$$SPACE(SRJ)_"The following "_SRTITLE_" was ADDED:" S SRNM=2
50 I SRVAL2="" D LINE(2) S @SRG@(SRI)=$$SPACE(SRJ)_"The following "_SRTITLE_" was DELETED:" S SRNM=1
51 S SRPF=1,SRVAL=$S(SRNM=1:SRVAL1,1:SRVAL2) D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ+2)_SRTITLE_": "_SRVAL
52 Q
53FPX S SRJ=SRJ+2 I SRNUM[";W" D WPM
54 S SRVAL="",SRY=$G(^TMP("SRARMULT"_SRNM,$J,SRTN,SRMULT,SRE,SRE1,SRFLD)) I SRY'="" D EXT S SRVAL=SRX
55 D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ)_SRTITLE_": "_SRVAL
56 Q
57FWPM ; word-processing in multiples in added or deleted entries
58 I '$O(^TMP("SRARAD1",$J,SRTN,SRMULT,SRE,SRE1,SRFLD,0)) S SRS=2
59 I '$O(^TMP("SRARAD2",$J,SRTN,SRMULT,SRE,SRE1,SRFLD,0)) S SRS=1
60 D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ)_SRTITLE_":" S SRLN=0
61 F S SRLN=$O(^TMP("SRARMULT"_SRS,$J,SRTN,SRMULT,SRE,SRE1,SRFLD,SRLN)) Q:'SRLN S X=^TMP("SRARMULT"_SRS,$J,SRTN,SRMULT,SRE,SRE1,SRFLD,SRLN) D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ)_X
62 Q
63WPM ; word-processing in multiples
64 I SRPF S SRJ=SRJ+2 D FWPM Q
65 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:"
66 I '$O(^TMP("SRARAD1",$J,SRTN,SRMULT,SRE,SRE1,SRFLD,0)) S @SRG@(SRI)=@SRG@(SRI)_" <NO TEXT ENTERED>" D WPM2 Q
67 S SRLN=0 F S SRLN=$O(^TMP("SRARMULT1",$J,SRTN,SRMULT,SRE,SRE1,SRFLD,SRLN)) Q:'SRLN S X=^TMP("SRARMULT1",$J,SRTN,SRMULT,SRE,SRE1,SRFLD,SRLN) D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ+2)_X
68WPM2 D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ+2)_">> to updated "_SRTITLE_" text:" I '$O(^TMP("SRARAD2",$J,SRTN,SRMULT,SRE,SRE1,SRFLD,0)) S @SRG@(SRI)=@SRG@(SRI)_" <TEXT DELETED>" Q
69 S SRLN=0 F S SRLN=$O(^TMP("SRARMULT2",$J,SRTN,SRMULT,SRE,SRE1,SRFLD,SRLN)) Q:'SRLN S X=^TMP("SRARMULT2",$J,SRTN,SRMULT,SRE,SRE1,SRFLD,SRLN) D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ+2)_X
70 Q
71SPACE(NUM) ; create spaces
72 ; pass in position, returns number of needed spaces
73 I '$D(@SRG@(SRI)) S @SRG@(SRI)=""
74 Q $J("",NUM-$L(@SRG@(SRI)))
75 Q
76LINE(NUM) ; create carriage returns
77 F J=1:1:NUM S SRI=SRI+1,@SRG@(SRI)=""
78 Q
Note: See TracBrowser for help on using the repository browser.