source: WorldVistAEHR/trunk/r/SURGERY-SR/SROESAD1.m@ 1351

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

initial load of WorldVistAEHR
File size: 5.7 KB
RevLine 
[613]1SROESAD1 ;BIR/ADM - SURGERY E-SIG UTILITY ; [ 04/16/01 1:03 PM ]
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,SRPRE,SRS,SRSUB,SRTITLE,SRVAL,SRVAL1,SRVAL2,SRX,SRY,X
9 F SRJ="SRADDEND","SRAD1","SRAD2","SRADM1","SRADM2" K ^TMP(SRJ,$J,SRTN)
10 S SRI=0,SRG=$NA(^TMP("SRADDEND",$J,SRTN)) K @SRG
11 D GET^SROESAD
12SING ; single fields
13 S SRFLD="" F S SRFLD=$O(^TMP("SRAD1",$J,SRTN,130,SRFLD)) Q:SRFLD="" D
14 .S SRTITLE=$P(SRFLD,"-"),X=$P(SRFLD,"-",2),SRFILE=$P(X,","),SRNUM=$P(X,",",2) I SRNUM[";W" D WPS Q
15 .S SRVAL1="<NOT ENTERED>",SRY=$G(^TMP("SRAD1",$J,SRTN,130,SRFLD)) I SRY'="" D EXT S SRVAL1=SRX
16 .S SRVAL2="<DELETED>",SRY=$G(^TMP("SRAD2",$J,SRTN,130,SRFLD)) I SRY'="" D EXT S SRVAL2=SRX
17 .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
18MULT ; multiples
19 S SRMULT="" F S SRMULT=$O(^TMP("SRADM1",$J,SRTN,SRMULT)) Q:SRMULT="" D
20 .D LINE(2) S @SRG@(SRI)="The "_SRMULT_" subfile was changed as follows:"
21 .S SRE=0 F S SRE=$O(^TMP("SRADM1",$J,SRTN,SRMULT,SRE)) Q:'SRE D
22 ..S SRE1="",SRJ=2,SRPF=0 F S SRE1=$O(^TMP("SRADM1",$J,SRTN,SRMULT,SRE,SRE1)) Q:SRE1="" D Q:SRE1=""
23 ...S SRFLD="" F S SRFLD=$O(^TMP("SRADM1",$J,SRTN,SRMULT,SRE,SRE1,SRFLD)) Q:SRFLD="" D PROC Q:SRFLD=""
24 Q
25WPS ; word-processing fields
26 D LINE(2) S @SRG@(SRI)="The "_SRTITLE_" field was changed" D LINE(1) S @SRG@(SRI)=" >> from original "_SRTITLE_" text:"
27 I '$O(^TMP("SRAD1",$J,SRTN,130,SRFLD,0)) S @SRG@(SRI)=@SRG@(SRI)_" <NO TEXT ENTERED>"
28 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
29WPS2 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>"
30 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
31 Q
32EXT ; get external value
33 S SRX=$$EXTERNAL^DILFD(SRFILE,SRNUM,"",SRY)
34 I SRFILE=130 D Q
35 .I SRNUM=27,SRX'="" S SRX=$E(SRX,1,5) D CPT Q
36 .I SRNUM=66 D DIAG
37 I SRFILE=130.16,SRNUM=3,SRX'="" S SRX=$E(SRX,1,5) D CPT Q
38 I SRFILE=130.18,SRNUM=3 D DIAG
39 Q
40DIAG S SRY=$$ICDDX^ICDCODE(SRY,$P($G(^SRF(SRTN,0)),"^",9)),SRX=SRX_" "_$P(SRY,"^",4)
41 Q
42CPT S X=$$CPT^ICPTCOD(SRX,$P($G(^SRF(SRTN,0)),"^",9)),SRX=SRX_" "_$P(X,"^",3)
43 Q
44PROC 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
45 S SRVAL1="",SRY=$G(^TMP("SRADM1",$J,SRTN,SRMULT,SRE,SRE1,SRFLD)) I SRY'="" D EXT S SRVAL1=SRX
46 S SRVAL2="",SRY=$G(^TMP("SRADM2",$J,SRTN,SRMULT,SRE,SRE1,SRFLD)) I SRY'="" D EXT S SRVAL2=SRX
47 I $P(SRFLD,"-")="01",SRVAL1=""!(SRVAL2="") D FP01 Q
48 I 'SRPF,$P(SRNUM,";")=.01,SRVAL1=""!(SRVAL2="") D FP01S Q
49 I SRPF D FPX Q
50 S:SRVAL1="" SRVAL1="<NOT ENTERED>" S:SRVAL2="" SRVAL2="<DELETED>"
51 I SRVAL2=SRVAL1 D:$P(SRFLD,"-")="01" LINE(1) D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ)_"The "_SRTITLE_" entry "_SRVAL1_" was changed:" Q
52 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
53 Q
54FP01S ; add or delete subfile entry
55 I SRVAL1="" D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ)_"The following "_SRTITLE_" was ADDED:" S SRNM=2
56 I SRVAL2="" D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ)_"The following "_SRTITLE_" was DELETED:" S SRNM=1
57 S SRPF=1,SRVAL=$S(SRNM=1:SRVAL1,1:SRVAL2) D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ+2)_SRTITLE_": "_SRVAL
58 Q
59FP01 ; add or delete
60 I SRVAL1="" D LINE(2) S @SRG@(SRI)=$$SPACE(SRJ)_"The following "_SRTITLE_" was ADDED:" S SRNM=2
61 I SRVAL2="" D LINE(2) S @SRG@(SRI)=$$SPACE(SRJ)_"The following "_SRTITLE_" was DELETED:" S SRNM=1
62 S SRPF=1,SRVAL=$S(SRNM=1:SRVAL1,1:SRVAL2) D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ+2)_SRTITLE_": "_SRVAL
63 Q
64FPX S SRJ=SRJ+2 I SRNUM[";W" D WPM
65 S SRVAL="",SRY=$G(^TMP("SRADM"_SRNM,$J,SRTN,SRMULT,SRE,SRE1,SRFLD)) I SRY'="" D EXT S SRVAL=SRX
66 D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ)_SRTITLE_": "_SRVAL
67 Q
68FWPM ; word-processing in multiples in added or deleted entries
69 I '$O(^TMP("SRAD1",$J,SRTN,SRMULT,SRE,SRE1,SRFLD,0)) S SRS=2
70 I '$O(^TMP("SRAD2",$J,SRTN,SRMULT,SRE,SRE1,SRFLD,0)) S SRS=1
71 D LINE(1) S @SRG@(SRI)=$$SPACE(SRJ)_SRTITLE_":" S SRLN=0
72 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
73 Q
74WPM ; word-processing in multiples
75 I SRPF S SRJ=SRJ+2 D FWPM Q
76 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:"
77 I '$O(^TMP("SRAD1",$J,SRTN,SRMULT,SRE,SRE1,SRFLD,0)) S @SRG@(SRI)=@SRG@(SRI)_" <NO TEXT ENTERED>" D WPM2 Q
78 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
79WPM2 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
80 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
81 Q
82SPACE(NUM) ; create spaces
83 ; pass in position, returns number of needed spaces
84 I '$D(@SRG@(SRI)) S @SRG@(SRI)=""
85 Q $J("",NUM-$L(@SRG@(SRI)))
86 Q
87LINE(NUM) ; create carriage returns
88 F J=1:1:NUM S SRI=SRI+1,@SRG@(SRI)=""
89 Q
Note: See TracBrowser for help on using the repository browser.