source: FOIAVistA/tag/r/SURGERY-SR/SROESNR2.m@ 628

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

initial load of FOIAVistA 6/30/08 version
File size: 5.6 KB
Line 
1SROESNR2 ;BIR/ADM - NURSE REPORT E-SIG UTILITY ; [ 03/21/01 6:36 AM
2 ;;3.0; Surgery ;**100,127**;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("SRNR",$J,SRTN)) K @SRG
10SING ; single fields
11 S SRFLD="" F S SRFLD=$O(^TMP("SRNRAD1",$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("SRNRAD1",$J,SRTN,130,SRFLD)) I SRY'="" D EXT S SRVAL1=SRX
14 .S SRVAL2="<DELETED>",SRY=$G(^TMP("SRNRAD2",$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("SRNRMULT1",$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("SRNRMULT1",$J,SRTN,SRMULT,SRE)) Q:'SRE D
20 ..S SRE1="",SRJ=2,SRPF=0 F S SRE1=$O(^TMP("SRNRMULT1",$J,SRTN,SRMULT,SRE,SRE1)) Q:SRE1="" D Q:SRE1=""
21 ...S SRFLD="" F S SRFLD=$O(^TMP("SRNRMULT1",$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("SRNRAD1",$J,SRTN,130,SRFLD,0)) S @SRG@(SRI)=@SRG@(SRI)_" <NO TEXT ENTERED>"
26 S SRLN=0 F S SRLN=$O(^TMP("SRNRAD1",$J,SRTN,130,SRFLD,SRLN)) Q:'SRLN S X=^TMP("SRNRAD1",$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("SRNRAD2",$J,SRTN,130,SRFLD,0)) S @SRG@(SRI)=@SRG@(SRI)_" <TEXT DELETED>"
28 S SRLN=0 F S SRLN=$O(^TMP("SRNRAD2",$J,SRTN,130,SRFLD,SRLN)) Q:'SRLN S X=^TMP("SRNRAD2",$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 I SRFILE=130 D Q
33 .I SRNUM=27,SRX'="" S SRX=$E(SRX,1,5) D CPT Q
34 .I SRNUM=66 D DIAG
35 I SRFILE=130.16,SRNUM=3,SRX'="" S SRX=$E(SRX,1,5) D CPT Q
36 I SRFILE=130.18,SRNUM=3 D DIAG
37 Q
38DIAG S SRY=$$ICDDX^ICDCODE(SRY,$P($G(^SRF(SRTN,0)),"^",9)) S SRX=SRX_" "_$P(SRY,"^",4) K SRY
39 Q
40CPT S X=$$CPT^ICPTCOD(SRX,$P($G(^SRF(SRTN,0)),"^",9)),SRX=SRX_" "_$P(X,"^",3)
41 Q
42PROC 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
43 S SRVAL1="",SRY=$G(^TMP("SRNRMULT1",$J,SRTN,SRMULT,SRE,SRE1,SRFLD)) I SRY'="" D EXT S SRVAL1=SRX
44 S SRVAL2="",SRY=$G(^TMP("SRNRMULT2",$J,SRTN,SRMULT,SRE,SRE1,SRFLD)) I SRY'="" D EXT S SRVAL2=SRX
45 I $P(SRFLD,"-")="01",SRVAL1=""!(SRVAL2="") D FP01 Q
46 I 'SRPF,$P(SRNUM,";")=.01,SRVAL1=""!(SRVAL2="") D FP01S Q
47 I SRPF D FPX Q
48 S:SRVAL1="" SRVAL1="<NOT ENTERED>" S:SRVAL2="" SRVAL2="<DELETED>"
49 I SRVAL2=SRVAL1 D:$P(SRFLD,"-")="01" LINE(1) D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ)_"The "_SRTITLE_" entry "_SRVAL1_" was changed:" Q
50 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
51 Q
52FP01S ; add or delete subfile entry
53 I SRVAL1="" D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ)_"The following "_SRTITLE_" was ADDED:" S SRNM=2
54 I SRVAL2="" D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ)_"The following "_SRTITLE_" was DELETED:" S SRNM=1
55 S SRPF=1,SRVAL=$S(SRNM=1:SRVAL1,1:SRVAL2) D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ+2)_SRTITLE_": "_SRVAL
56 Q
57FP01 ; add or delete
58 I SRVAL1="" D LINE(2) S @SRG@(SRI)=$$SPACE(SRJ)_"The following "_SRTITLE_" was ADDED:" S SRNM=2
59 I SRVAL2="" D LINE(2) S @SRG@(SRI)=$$SPACE(SRJ)_"The following "_SRTITLE_" was DELETED:" S SRNM=1
60 S SRPF=1,SRVAL=$S(SRNM=1:SRVAL1,1:SRVAL2) D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ+2)_SRTITLE_": "_SRVAL
61 Q
62FPX S SRJ=SRJ+2 I SRNUM[";W" D WPM
63 S SRVAL="",SRY=$G(^TMP("SRNRMULT"_SRNM,$J,SRTN,SRMULT,SRE,SRE1,SRFLD)) I SRY'="" D EXT S SRVAL=SRX
64 D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ)_SRTITLE_": "_SRVAL
65 Q
66FWPM ; word-processing in multiples in added or deleted entries
67 I '$O(^TMP("SRNRAD1",$J,SRTN,SRMULT,SRE,SRE1,SRFLD,0)) S SRS=2
68 I '$O(^TMP("SRNRAD2",$J,SRTN,SRMULT,SRE,SRE1,SRFLD,0)) S SRS=1
69 D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ)_SRTITLE_":" S SRLN=0
70 F S SRLN=$O(^TMP("SRNRMULT"_SRS,$J,SRTN,SRMULT,SRE,SRE1,SRFLD,SRLN)) Q:'SRLN S X=^TMP("SRNRMULT"_SRS,$J,SRTN,SRMULT,SRE,SRE1,SRFLD,SRLN) D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ)_X
71 Q
72WPM ; word-processing in multiples
73 I SRPF S SRJ=SRJ+2 D FWPM Q
74 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:"
75 I '$O(^TMP("SRNRAD1",$J,SRTN,SRMULT,SRE,SRE1,SRFLD,0)) S @SRG@(SRI)=@SRG@(SRI)_" <NO TEXT ENTERED>" D WPM2 Q
76 S SRLN=0 F S SRLN=$O(^TMP("SRNRMULT1",$J,SRTN,SRMULT,SRE,SRE1,SRFLD,SRLN)) Q:'SRLN S X=^TMP("SRNRMULT1",$J,SRTN,SRMULT,SRE,SRE1,SRFLD,SRLN) D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ+2)_X
77WPM2 D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ+2)_">> to updated "_SRTITLE_" text:" I '$O(^TMP("SRNRAD2",$J,SRTN,SRMULT,SRE,SRE1,SRFLD,0)) S @SRG@(SRI)=@SRG@(SRI)_" <TEXT DELETED>" Q
78 S SRLN=0 F S SRLN=$O(^TMP("SRNRMULT2",$J,SRTN,SRMULT,SRE,SRE1,SRFLD,SRLN)) Q:'SRLN S X=^TMP("SRNRMULT2",$J,SRTN,SRMULT,SRE,SRE1,SRFLD,SRLN) D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ+2)_X
79 Q
80SPACE(NUM) ; create spaces
81 ; pass in position, returns number of needed spaces
82 I '$D(@SRG@(SRI)) S @SRG@(SRI)=""
83 Q $J("",NUM-$L(@SRG@(SRI)))
84 Q
85LINE(NUM) ; create carriage returns
86 F J=1:1:NUM S SRI=SRI+1,@SRG@(SRI)=""
87 Q
Note: See TracBrowser for help on using the repository browser.