source: WorldVistAEHR/trunk/r/SURGERY-SR/SROANP.m@ 1259

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

initial load of WorldVistAEHR

File size: 3.4 KB
Line 
1SROANP ;B'HAM ISC/MAM - LIST OF ANESTHETIC PROCEDURES ; [ 09/07/00 11:27 AM ]
2 ;;3.0; Surgery ;**38,53,50,95,151**;24 Jun 93
3 ;
4 ;Reference to ^PSS50 supported by DBIA #4533
5 ;
6SET ; set and print information for a case
7 S SRNON=0 I $P($G(^SRF(SRTN,"NON")),"^")="Y" S SRNON=1
8 I SRFLG=1!(SRFLG=3&('SRNON)) Q:$P($G(^SRF(SRTN,.2)),"^",12)=""
9 I SRFLG=2 Q:'SRNON
10 K S(.2),SRAGNT,SRTECH,SRPRIN,SRANE3
11 S S(0)=^SRF(SRTN,0),DFN=+S(0) D DEM^VADPT S SRDPT=VADM(1),SRSSN=VA("PID"),SRDATE=$P(S(0),"^",9),Y=SRDATE,SRDT=$E(SRDATE,4,5)_"/"_$E(SRDATE,6,7)_"/"_$E(SRDATE,2,3)
12 D D^DIQ S SRFIND=$F(Y,":") S SRDATE=$S(SRFIND:SRDT_" "_$E(Y,SRFIND-3,SRFIND+1),1:SRDT)
13 S:SRDPT>18 SRDPT=$P(SRDPT,",")_", "_$E($P(SRDPT,",",2))
14 I 'SRNON S SRICD=$S($D(^SRF(SRTN,34)):$P(^(34),"^"),$D(^SRF(SRTN,33)):$P(^(33),"^"),1:"")
15 I SRNON S SRICD=$P($G(^SRF(SRTN,33)),"^",2)
16OPS S SROPER=$P(^SRF(SRTN,"OP"),"^"),OPER=0 F S OPER=$O(^SRF(SRTN,13,OPER)) Q:OPER="" D OTHER
17 K SROPS,MM,MMM S:$L(SROPER)<50 SROPS(1)=SROPER I $L(SROPER)>49 S SROPER=SROPER_" " F M=1:1 D LOOP Q:MMM=""
18 S SRPRIN=$S($D(^SRF(SRTN,.3)):$P(^(.3),"^"),1:"") I SRPRIN'="" S SRPRIN=$P(^VA(200,SRPRIN,0),"^")
19 S Y=$P($G(^SRF(SRTN,1.1)),"^",3),C=$P(^DD(130,1.13,0),"^",2) D:Y'="" Y^DIQ S SRASA=$P(Y,"-",2,3)
20 K SRTECH S (SRT,SRZ)=0 F S SRT=$O(^SRF(SRTN,6,SRT)) Q:SRT=""!(SRZ) D ^SROPRIN I SRZ D AGENT
21 I '$D(SRTECH) S (SRTECH,SRAGNT)=""
22 S:'$D(SRAGNT) SRAGNT=""
23 I SRTECH'="" S Y=SRTECH,C=$P(^DD(130.06,.01,0),"^",2) D Y^DIQ S SRTECH=Y
24 I $D(^SRF(SRTN,.2)) S S(.2)=^(.2),SRANE1=$P(S(.2),"^",1),SRANE2=$P(S(.2),"^",4) S X1=SRANE2,X=SRANE1 I X1,X D MINS^SRSUTL2 S SRANE3=X
25 S:'$D(SRANE3) SRANE3="" I '$D(S(.2)) S (SRANE1,SRANE2)=""
26 I SRANE1 S Y=SRANE1 D D^DIQ S SRFIND=$F(Y,":"),SRANE1=$S(SRFIND:$E(Y,SRFIND-3,SRFIND+1),1:"")
27 I SRANE2 S Y=SRANE2 D D^DIQ S SRFIND=$F(Y,":"),SRANE2=$S(SRFIND:$E(Y,SRFIND-3,SRFIND+1),1:"")
28PRINT ; print results
29 I $Y+7>IOSL D PAGE
30 Q:SRF W !,SRDATE,?16,SRDPT,?40,SRICD,?97,$E(SRPRIN,1,15),?118,SRANE1,!,SRTN,?16,VA("PID"),?40,SROPS(1),?97,$E(SRTECH,1,20),?118,SRANE2
31 W ! W:SRFLG=3&(SRNON) "NON-O.R." W ?16,SRASA W:$D(SROPS(2)) ?40,SROPS(2) W ?97,$E(SRAGNT,1,20),?118,SRANE3,!
32 I $D(SROPS(3)) W ?40,SROPS(3),! I $D(SROPS(4)) W ?40,SROPS(4),! I $D(SROPS(5)) W ?40,SROPS(5),! I $D(SROPS(6)) W ?40,SROPS(6),!
33 Q
34OTHER ; other operations
35 S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,OPER,0),"^"))>250 S SRLONG=0,OPER=999,SROPERS=" ..."
36 I SRLONG S SROPERS=$P(^SRF(SRTN,13,OPER,0),"^")
37 S SROPER=SROPER_$S(SROPERS=" ...":SROPERS,1:", "_SROPERS)
38 Q
39LOOP ; break procedure name if greater than 50 characters
40 S SROPS(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM="" Q:$L(SROPS(M))+$L(MM)'<50 S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM
41 Q
42AGENT S SRAGNT=$O(^SRF(SRTN,6,SRT,1,0)) Q:SRAGNT="" S SRAGNT=$P(^SRF(SRTN,6,SRT,1,SRAGNT,0),"^") D
43 .D DATA^PSS50(SRAGNT,,,,,"SRRX") S SRAGNT=$P($G(^TMP($J,"SRRX",SRAGNT,.01)),"^") K ^TMP($J,"SRRX",SRAGNT)
44 Q
45BEG ;
46 U IO N SRFRTO S SRED1=SRED_.9999,SRF=0,PAGE=1,Y=DT X ^DD("DD") S SRPRINT="DATE PRINTED: "_Y S Y=SRSD X ^DD("DD") S SRFRTO="FROM: "_Y_" TO: ",Y=SRED X ^DD("DD") S SRFRTO=SRFRTO_Y
47 S SRINST=SRSITE("SITE"),SRINSTP=SRSITE("DIV") D HDR^SROANP1 Q:SRF
48 S DATE=SRSD-.0009 F S DATE=$O(^SRF("AC",DATE)) Q:DATE>SRED1!(DATE="")!SRF S SRTN=0 F S SRTN=$O(^SRF("AC",DATE,SRTN)) Q:SRTN=""!SRF I $D(^SRF(SRTN,0)),$$DIV^SROUTL0(SRTN) D SET
49 Q
50PAGE I $E(IOST)'="P" W !!,"Press RETURN to continue, '^' to quit " R ASK:DTIME I '$T!(ASK="^") S SRF=1 Q
51 D HDR^SROANP1 Q
Note: See TracBrowser for help on using the repository browser.