source: WorldVistAEHR/trunk/r/SURGERY-SR/SRSCOR.m@ 700

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

initial load of WorldVistAEHR

File size: 3.8 KB
Line 
1SRSCOR ;B'HAM ISC/SJA - Surgery/CoreFLS API ; [ 12/6/01 8:59 AM ]
2 ;;3.0; Surgery ;**107,127**;24 Jun 93
3 ;
4 ; Reference to $$MOD^ICPTMOD supported by DBIA #1996
5 ; Reference to $$BLDSEG^CSLSUR1 is supported by DBIA #3498
6 ; Reference to ^DIC(45.3 is supported by DBIA #218
7 ; Reference to ^TMP("CSLSUR1" is supported by DBIA #3498
8 ;
9ST(SRTN) S X="CSLSUR1" X ^%ZOSF("TEST") G:'$T EXIT
10 N DYNOTE,II,JJ,MM,L,LSS,LSSC,LSSN,NSSIEN,OCIEN,OCPT,OMIEN,OR,ORN,PM,PMIEN,SPF,SRNODE0,SRNODE30,SRNODE31,SROP,SURGN,ASURG,SRICN,SRICPT,SRSP,SROP,SROPER
11 K ^TMP("CSLSUR1",$J)
12 S SRNODE0=$G(^SRF(SRTN,0)),SRNODE30=$G(^SRF(SRTN,30)),SRNODE31=$G(^SRF(SRTN,31))
13AR1 ; Schedule ID
14 S ^TMP("CSLSUR1",$J,1)=SRTN
15AR2 ; Patient ID (DFN) and ICN
16 S X="MPIF001",SRICN="" X ^%ZOSF("TEST") I $T S SRICN=$$GETICN^MPIF001($P(SRNODE0,"^"))
17 S ^TMP("CSLSUR1",$J,2)=$P(SRNODE0,"^")_"^"_$S($P(SRICN,"^")=-1:"",1:SRICN)
18AR3 ; Type of Action
19 S ^TMP("CSLSUR1",$J,3)=SRTYPE
20 ;$S(SRTYPE=1:"NEW",SRTYPE=2:"EDIT",SRTYPE=3:"CANCEL",SRTYPE=4:"DELETE",1:"")
21AR4 ; Date/Time of Surgery
22 S ^TMP("CSLSUR1",$J,4)=$P(SRNODE31,"^",4)_"^"_$P(SRNODE31,"^",5)_"^"_$P(SRNODE0,"^",9)
23 ;
24AR5 ; Principle CPT code & Name
25 S SROP=$G(^SRF(SRTN,"OP")),^TMP("CSLSUR1",$J,5,0)=$P(SROP,"^")
26 I +$P(SROP,"^",2) S SRICPT=$$CPT^ICPTCOD($P(SROP,"^",2),$P($G(^SRF(SRTN,0)),"^",9)),^TMP("CSLSUR1",$J,5,1)=$P(SRICPT,"^",2)_"^"_$P(SRICPT,"^",3)
27 ;
28 ; CPT modifiers for principle code (X = sequential number)
29 S PM=0 F S PM=$O(^SRF(SRTN,"OPMOD",PM)) Q:'PM S PMIEN=$P($G(^(PM,0)),"^") D
30 .S ^TMP("CSLSUR1",$J,5,1,PM)=$P($$MOD^ICPTMOD(PMIEN,"I",$P($G(^SRF(SRTN,0)),"^",9)),"^",2,3)
31 ;
32 ; Other CPT codes and names (N = value greater than 1)
33 S II=0,JJ=1 F S II=$O(^SRF(SRTN,13,II)) Q:'II S OCIEN=$G(^(II,2)) D
34 .I +OCIEN S OCPT=$$CPT^ICPTCOD(+OCIEN,$P($G(^SRF(SRTN,0)),"^",9)) S JJ=JJ+1,^TMP("CSLSUR1",$J,5,JJ)=$P(OCPT,"^",2)_"^"_$P(OCPT,"^",3)
35 .;
36 .;CPT code modifiers
37 .S MM=0 F S MM=$O(^SRF(SRTN,13,II,"MOD",MM)) Q:'MM S OMIEN=$G(^SRF(SRTN,13,II,"MOD",MM,0)),^TMP("CSLSUR1",$J,5,JJ,MM)=$P($$MOD^ICPTMOD(OMIEN,"I",$P($G(^SRF(SRTN,0)),"^",9)),"^",2,3)
38AR6 ; Surgeon ID & Name
39 S SURGN=$P($G(^SRF(SRTN,.1)),"^",4)
40 I +SURGN S ^TMP("CSLSUR1",$J,6)=SURGN_"^"_$P($G(^VA(200,+SURGN,0)),"^")
41AR7 ; Surgical Specialty Code & Name
42 S LSSC=+$P(SRNODE0,"^",4),LSS=$G(^SRO(137.45,LSSC,0)),LSSN=$P(LSS,"^")
43 S NSSIEN=$P(LSS,"^",2)
44 I +NSSIEN S ^TMP("CSLSUR1",$J,7)=$P($G(^DIC(45.3,+NSSIEN,0)),"^",1,2)
45AR8 ; Local Surgical Specialty Code & Name
46 I +LSSC!(LSSN'="") S ^TMP("CSLSUR1",$J,8)=$P(LSS,"^",4)_"^"_LSSN
47AR9 ; Operating Room
48 S OR=$P(SRNODE0,"^",2),JJ=$P($G(^SRS(+OR,0)),"^"),ORN=$G(^SC(+JJ,0))
49 I +JJ S ^TMP("CSLSUR1",$J,9)=JJ_"^"_$P(ORN,"^")
50AR10 ; SPD Comments
51 S L=0 F S L=$O(^SRF(SRTN,80,L)) Q:'L S X=$G(^SRF(SRTN,80,L,0)) D
52 .S ^TMP("CSLSUR1",$J,10,L)=X
53AR11 ; Hospital
54 S SPF=$P($G(^SRO(133,+$$SITE^SROUTL0(SRTN),0)),"^")
55 I +SPF S ^TMP("CSLSUR1",$J,11)=SPF_"^"_$$GET1^DIQ(4,+SPF,.01)
56AR12 ; Scheduled by
57 S SRSP=$P($G(^SRF(SRTN,"1.0")),"^",10)
58 I +SRSP S ^TMP("CSLSUR1",$J,12)=SRSP_"^"_$P($G(^VA(200,+SRSP,0)),"^")
59AR13 ; Entered by
60 S ^TMP("CSLSUR1",$J,13)=DUZ_"^"_$P($G(^VA(200,+DUZ,0)),"^")
61AR14 ; IN/OUT-PATIENT STATUS
62 I $P(SRNODE0,"^",12)'="" S ^TMP("CSLSUR1",$J,14)=$P(SRNODE0,"^",12)
63AR15 ; Time Stamp
64 D NOW^%DTC S ^TMP("CSLSUR1",$J,15)=%
65AR16 ; Attending Surgeon
66 S ASURG=$P($G(^SRF(SRTN,.1)),"^",13)
67 I +ASURG S ^TMP("CSLSUR1",$J,16)=ASURG_"^"_$P($G(^VA(200,+ASURG,0)),"^")
68 ;
69SEND ; Call CoreFLS API
70 S DYNOTE=+$$BLDSEG^CSLSUR1(1)
71 I '$P(SRNODE31,"^",10) S $P(^SRF(SRTN,31),"^",10)=$S(DYNOTE=1:1,1:0)
72 S SROP=SRTN,SROPER="" D ^SROP1 I SROPER["REQUESTED" S $P(^SRF(SRTN,31),"^",10)=0
73EXIT K ^TMP("CSLSUR1",$J)
74 Q
75CHKS(SRDA) ; Calculate checksum of SPD COMMENTS field
76 N J,L,X,SRCSUM S SRCSUM=0
77 S L=0 F S L=$O(^SRF(SRDA,80,L)) Q:'L S X=^SRF(SRDA,80,L,0) F J=1:1:$L(X) S SRCSUM=L*J*$A(X,J)+SRCSUM
78 Q SRCSUM
Note: See TracBrowser for help on using the repository browser.