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

SROANP ;B'HAM ISC/MAM - LIST OF ANESTHETIC PROCEDURES ; [ 09/07/00  11:27 AM ]
 ;;3.0; Surgery ;**38,53,50,95,151**;24 Jun 93
 ;
 ;Reference to ^PSS50 supported by DBIA #4533
 ;
SET ; set and print information for a case
 S SRNON=0 I $P($G(^SRF(SRTN,"NON")),"^")="Y" S SRNON=1
 I SRFLG=1!(SRFLG=3&('SRNON)) Q:$P($G(^SRF(SRTN,.2)),"^",12)=""
 I SRFLG=2 Q:'SRNON
 K S(.2),SRAGNT,SRTECH,SRPRIN,SRANE3
 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)
 D D^DIQ S SRFIND=$F(Y,":") S SRDATE=$S(SRFIND:SRDT_" "_$E(Y,SRFIND-3,SRFIND+1),1:SRDT)
 S:SRDPT>18 SRDPT=$P(SRDPT,",")_", "_$E($P(SRDPT,",",2))
 I 'SRNON S SRICD=$S($D(^SRF(SRTN,34)):$P(^(34),"^"),$D(^SRF(SRTN,33)):$P(^(33),"^"),1:"")
 I SRNON S SRICD=$P($G(^SRF(SRTN,33)),"^",2)
OPS S SROPER=$P(^SRF(SRTN,"OP"),"^"),OPER=0 F  S OPER=$O(^SRF(SRTN,13,OPER)) Q:OPER=""  D OTHER
 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=""
 S SRPRIN=$S($D(^SRF(SRTN,.3)):$P(^(.3),"^"),1:"") I SRPRIN'="" S SRPRIN=$P(^VA(200,SRPRIN,0),"^")
 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)
 K SRTECH S (SRT,SRZ)=0 F  S SRT=$O(^SRF(SRTN,6,SRT)) Q:SRT=""!(SRZ)  D ^SROPRIN I SRZ D AGENT
 I '$D(SRTECH) S (SRTECH,SRAGNT)=""
 S:'$D(SRAGNT) SRAGNT=""
 I SRTECH'="" S Y=SRTECH,C=$P(^DD(130.06,.01,0),"^",2) D Y^DIQ S SRTECH=Y
 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
 S:'$D(SRANE3) SRANE3="" I '$D(S(.2)) S (SRANE1,SRANE2)=""
 I SRANE1 S Y=SRANE1 D D^DIQ S SRFIND=$F(Y,":"),SRANE1=$S(SRFIND:$E(Y,SRFIND-3,SRFIND+1),1:"")
 I SRANE2 S Y=SRANE2 D D^DIQ S SRFIND=$F(Y,":"),SRANE2=$S(SRFIND:$E(Y,SRFIND-3,SRFIND+1),1:"")
PRINT ; print results
 I $Y+7>IOSL D PAGE
 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
 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,!
 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),!
 Q
OTHER ; other operations
 S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,OPER,0),"^"))>250 S SRLONG=0,OPER=999,SROPERS=" ..."
 I SRLONG S SROPERS=$P(^SRF(SRTN,13,OPER,0),"^")
 S SROPER=SROPER_$S(SROPERS=" ...":SROPERS,1:", "_SROPERS)
 Q
LOOP ; break procedure name if greater than 50 characters
 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
 Q
AGENT S SRAGNT=$O(^SRF(SRTN,6,SRT,1,0)) Q:SRAGNT=""  S SRAGNT=$P(^SRF(SRTN,6,SRT,1,SRAGNT,0),"^") D
 .D DATA^PSS50(SRAGNT,,,,,"SRRX") S SRAGNT=$P($G(^TMP($J,"SRRX",SRAGNT,.01)),"^") K ^TMP($J,"SRRX",SRAGNT)
 Q
BEG ;
 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
 S SRINST=SRSITE("SITE"),SRINSTP=SRSITE("DIV") D HDR^SROANP1 Q:SRF
 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
 Q
PAGE I $E(IOST)'="P" W !!,"Press RETURN to continue, '^' to quit  " R ASK:DTIME I '$T!(ASK="^") S SRF=1 Q
 D HDR^SROANP1 Q