source: FOIAVistA/tag/r/SURGERY-SR/SROCMP.m@ 1540

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

initial load of FOIAVistA 6/30/08 version
File size: 5.1 KB
Line 
1SROCMP ;BIR/MAM - PERIOPERATIVE OCCURRENCES ;05/15/06
2 ;;3.0; Surgery ;**22,26,29,38,50,143,153**;24 Jun 93;Build 11
3BEG U IO S SRSOUT=0,PAGE=1 K ^TMP("SR",$J) S Y=DT X ^DD("DD") S SRPRINT="DATE PRINTED: "_Y,SRSDT=SRSD-.0001,SREDT=SRED+.9999
4 N SRFRTO S Y=SRSD X ^DD("DD") S SRFRTO="FROM: "_Y_" TO: ",Y=SRED X ^DD("DD") S SRFRTO=SRFRTO_Y
5 F S SRSDT=$O(^SRF("AC",SRSDT)) Q:SRSDT>SREDT!('SRSDT)!(SRSOUT) S SRTN=0 F S SRTN=$O(^SRF("AC",SRSDT,SRTN)) Q:'SRTN!(SRSOUT) I $O(^SRF(SRTN,10,0))!$O(^SRF(SRTN,16,0)),$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTIL
6 S (SRSS,SRHDR)=0 F S SRSS=$O(^TMP("SR",$J,SRSS)) Q:SRSS=""!(SRSOUT) D HDR^SROCMP2 S SRSDATE=0 F S SRSDATE=$O(^TMP("SR",$J,SRSS,SRSDATE)) Q:'SRSDATE!(SRSOUT) D MORE
7 G:SRSOUT END
8 I '$D(^TMP("SR",$J)) D HDR^SROCMP2 G:SRSOUT END W !!,"There are no perioperative occurrences recorded for the selected date range."
9 F I=$Y:1:IOSL-9 W !
10 S X="" D FOOT^SROCMP2
11 I SRBOTH S SRSOUT=0 D BEG^SROMORT S SRSOUT=1
12END W:$E(IOST)="P" @IOF I $D(ZTQUEUED) K ^TMP("SR",$J) Q:$G(ZTSTOP) S ZTREQ="@" Q
13 D ^%ZISC,^SRSKILL K SRTN W @IOF
14 Q
15MORE S SRTN=0 F S SRTN=$O(^TMP("SR",$J,SRSS,SRSDATE,SRTN)) Q:'SRTN D SET
16 Q
17ATT N SRDIV,SRY S SRY=$P($G(^SRF(SRTN,.1)),"^",13) I SRY D
18 .S Y=SRY,C=$P(^DD(130,.164,0),"^",2) D Y^DIQ S SRSS=Y
19 I SRY="" S SRDIV=$$SITE^SROUTL0(SRTN) I SRDIV,'$P(^SRO(133,SRDIV,0),"^",19) D
20 .S SRY=$P($G(^SRF(SRTN,.1)),"^",4) I SRY D
21 ..S Y=SRY,C=$P(^DD(130,.14,0),"^",2) D Y^DIQ S SRSS=Y
22 S:'SRY SRY="ZZ" I SRSP,'$D(SRSP(SRY)) Q
23 S:'SRY SRSS="ATTENDING SURGEON NOT ENTERED"
24 S ^TMP("SR",$J,SRSS,SRSDT,SRTN)=""
25 Q
26UTIL ; set ^TMP
27 I SRSEL=1 D Q
28 .S Y=$P(^SRF(SRTN,0),"^",4) S:'Y Y="ZZ" I SRSP,'$D(SRSP(Y)) Q
29 .S SRSS=$S(Y:$P(^SRO(137.45,Y,0),"^"),1:"SURGICAL SPECIALTY NOT ENTERED")
30 .S ^TMP("SR",$J,SRSS,SRSDT,SRTN)=""
31 I SRSEL=2 D ATT Q
32 I SRSEL=3 F SRI=10,16 S SROCC=0 F S SROCC=$O(^SRF(SRTN,SRI,SROCC)) Q:'SROCC S Y=$P(^SRF(SRTN,SRI,SROCC,0),"^",2) D:Y
33 .I SRSP,'$D(SRSP(Y)) Q
34 .S SRSS=$S(Y:$P(^SRO(136.5,Y,0),"^"),1:"OCCURRENCE CATEGORY NOT ENTERED")
35 .S ^TMP("SR",$J,SRSS,SRSDT,SRTN)=""
36 Q
37SET ; set variables to print
38 K SRC S DFN=$P(^SRF(SRTN,0),"^") D DEM^VADPT S SRNM=VADM(1),SRSSN=VA("PID"),Y=$P(^SRF(SRTN,0),"^",9) D D^DIQ S SROD=$E(Y,1,18)
39OPS S SROPER=$P(^SRF(SRTN,"OP"),"^"),OPER=0 F S OPER=$O(^SRF(SRTN,13,OPER)) Q:OPER="" D OTHER
40 K SRP,Z S:$L(SROPER)<50 SRP(1)=SROPER I $L(SROPER)>49 S SROPER=SROPER_" " F M=1:1 D OPER Q:Z=""
41 S SRATT="",Y=$P($G(^SRF(SRTN,.1)),"^",13) I Y S C=$P(^DD(130,.164,0),"^",2) D Y^DIQ S SRATT=Y
42 I SRATT="" S SRDIV=$$SITE^SROUTL0(SRTN) I SRDIV,'$P(^SRO(133,SRDIV,0),"^",19) D
43 .S Y=$P($G(^SRF(SRTN,.1)),"^",4),C=$P(^DD(130,.14,0),"^",2) D Y^DIQ S SRATT=Y
44 I SRATT="" S SRATT="ATTENDING SURGEON NOT ENTERED"
45 S Y=$P(^SRF(SRTN,0),"^",4),SRSPEC=$S(Y:$P(^SRO(137.45,Y,0),"^"),1:"SURGICAL SPECIALTY NOT ENTERED")
46COMP ; perioperative occurrences
47 S (SRFG,SRIC,SRPC)=0 F S SRIC=$O(^SRF(SRTN,10,SRIC)) Q:SRIC="" S SRFG=SRFG+1,SRC(SRFG)=$P(^(SRIC,0),"^")_"^"_$P(^(0),"^",6)_"^^"_$S($D(^SRF(SRTN,10,SRIC,2)):$P(^(2),"^"),1:"")_"^10^"_SRIC
48 S SRPC=0 F S SRPC=$O(^SRF(SRTN,16,SRPC)) Q:SRPC="" D
49 .S SRFG=SRFG+1,SRC(SRFG)=$P(^SRF(SRTN,16,SRPC,0),"^")_" *^"_$P(^(0),"^",6)_"^"_$P(^(0),"^",7)_"^"_$S($D(^SRF(SRTN,16,SRPC,2)):$P(^(2),"^"),1:"")_"^16^"_SRPC
50 .I $P(^SRF(SRTN,16,SRPC,0),"^",2)=3 S SRC(SRFG)=SRC(SRFG)_"^"_$P(^SRF(SRTN,16,SRPC,0),"^",4)
51PRINT ; print perioperative occurrence information
52 I $Y+10>IOSL D HDR^SROCMP2 I SRSOUT Q
53 S SRHDR=1 W !!,SRNM,?29,$S(SRSEL=2:SRSPEC,1:SRATT) S SRC=$O(SRC(0)) W ?80,$P(SRC(SRC),"^") D DATE W ?129,$P(SRC(SRC),"^",2)
54 I SRSEL=3 D PRNT3 Q
55 W !,VA("PID"),?29,SRP(1),?80,$P(SRC(SRC),"^",4)
56 W !,SROD W:$D(SRP(2)) ?29,SRP(2) D TEXT W:$D(SRP(3))!SRT ! W:$D(SRP(3)) ?29,SRP(3) D:SRT WP
57SRC I SRC F S SRC=$O(SRC(SRC)) Q:'SRC!SRSOUT D
58 .I $Y+10>IOSL D HDR^SROCMP2 I SRSOUT Q
59 .W !,?80,$P(SRC(SRC),"^") D DATE W ?129,$P(SRC(SRC),"^",2),!,?80,$P(SRC(SRC),"^",4),! D TEXT I SRT W ! D WP
60 Q
61PRNT3 W !,VA("PID"),?29,SRSPEC,?80,$P(SRC(SRC),"^",4)
62 W !,SROD W ?29,SRP(1) D TEXT W:$D(SRP(2))!SRT ! W:$D(SRP(2)) ?29,SRP(2) D:SRT WP
63 D SRC
64 Q
65WP ; print perioperative occurrence comments
66 K ^UTILITY($J,"W") S CM=0 F S CM=$O(^SRF(SRTN,SRX,SRY,1,CM)) Q:'CM S X=^SRF(SRTN,SRX,SRY,1,CM,0),DIWL=81,DIWR=132 D ^DIWP
67 I $D(^UTILITY($J,"W")) F J=1:1:^UTILITY($J,"W",81) D
68 .I $Y+7>IOSL D HDR^SROCMP2 W ! I SRSOUT Q
69 .W ?81,^UTILITY($J,"W",81,J,0),!
70 Q
71TEXT ; check for comments
72 S SRT=0,SRX=$P(SRC(SRC),"^",5),SRY=$P(SRC(SRC),"^",6) I $O(^SRF(SRTN,SRX,SRY,1,0)) S SRT=1 I SRT W ?80,">>> Comments:"
73 Q
74OTHER ; other operations
75 S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,OPER,0),"^"))>250 S SRLONG=0,OPER=999,SROPERS=" ..."
76 I SRLONG S SROPERS=$P(^SRF(SRTN,13,OPER,0),"^")
77 S SROPER=SROPER_$S(SROPERS=" ...":SROPERS,1:", "_SROPERS)
78 Q
79OPER ; break procedure if greater than 50 characters
80 S SRP(M)="" F LOOP=1:1 S Z=$P(SROPER," ") Q:Z="" Q:$L(SRP(M))+$L(Z)'<50 S SRP(M)=SRP(M)_Z_" ",SROPER=$P(SROPER," ",2,200)
81 Q
82DATE N SRSEP
83 S X=$P(SRC(SRC),"^",7) I X S SRSEP=$S(X=2:"SEPSIS",X=3:"SEPTIC SHOCK",1:"SIRS") W " /"_SRSEP
84 I $P(SRC(SRC),"^",3)'="" S SRDT=$P(SRC(SRC),"^",3) I SRDT W " ("_$E(SRDT,4,5)_"/"_$E(SRDT,6,7)_"/"_$E(SRDT,2,3)_")"
85 Q
Note: See TracBrowser for help on using the repository browser.