SRSCOR ;B'HAM ISC/SJA - Surgery/CoreFLS API ; [ 12/6/01 8:59 AM ]
;;3.0; Surgery ;**107,127**;24 Jun 93
;
; Reference to $$MOD^ICPTMOD supported by DBIA #1996
; Reference to $$BLDSEG^CSLSUR1 is supported by DBIA #3498
; Reference to ^DIC(45.3 is supported by DBIA #218
; Reference to ^TMP("CSLSUR1" is supported by DBIA #3498
;
ST(SRTN) S X="CSLSUR1" X ^%ZOSF("TEST") G:'$T EXIT
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
K ^TMP("CSLSUR1",$J)
S SRNODE0=$G(^SRF(SRTN,0)),SRNODE30=$G(^SRF(SRTN,30)),SRNODE31=$G(^SRF(SRTN,31))
AR1 ; Schedule ID
S ^TMP("CSLSUR1",$J,1)=SRTN
AR2 ; Patient ID (DFN) and ICN
S X="MPIF001",SRICN="" X ^%ZOSF("TEST") I $T S SRICN=$$GETICN^MPIF001($P(SRNODE0,"^"))
S ^TMP("CSLSUR1",$J,2)=$P(SRNODE0,"^")_"^"_$S($P(SRICN,"^")=-1:"",1:SRICN)
AR3 ; Type of Action
S ^TMP("CSLSUR1",$J,3)=SRTYPE
;$S(SRTYPE=1:"NEW",SRTYPE=2:"EDIT",SRTYPE=3:"CANCEL",SRTYPE=4:"DELETE",1:"")
AR4 ; Date/Time of Surgery
S ^TMP("CSLSUR1",$J,4)=$P(SRNODE31,"^",4)_"^"_$P(SRNODE31,"^",5)_"^"_$P(SRNODE0,"^",9)
;
AR5 ; Principle CPT code & Name
S SROP=$G(^SRF(SRTN,"OP")),^TMP("CSLSUR1",$J,5,0)=$P(SROP,"^")
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)
;
; CPT modifiers for principle code (X = sequential number)
S PM=0 F S PM=$O(^SRF(SRTN,"OPMOD",PM)) Q:'PM S PMIEN=$P($G(^(PM,0)),"^") D
.S ^TMP("CSLSUR1",$J,5,1,PM)=$P($$MOD^ICPTMOD(PMIEN,"I",$P($G(^SRF(SRTN,0)),"^",9)),"^",2,3)
;
; Other CPT codes and names (N = value greater than 1)
S II=0,JJ=1 F S II=$O(^SRF(SRTN,13,II)) Q:'II S OCIEN=$G(^(II,2)) D
.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)
.;
.;CPT code modifiers
.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)
AR6 ; Surgeon ID & Name
S SURGN=$P($G(^SRF(SRTN,.1)),"^",4)
I +SURGN S ^TMP("CSLSUR1",$J,6)=SURGN_"^"_$P($G(^VA(200,+SURGN,0)),"^")
AR7 ; Surgical Specialty Code & Name
S LSSC=+$P(SRNODE0,"^",4),LSS=$G(^SRO(137.45,LSSC,0)),LSSN=$P(LSS,"^")
S NSSIEN=$P(LSS,"^",2)
I +NSSIEN S ^TMP("CSLSUR1",$J,7)=$P($G(^DIC(45.3,+NSSIEN,0)),"^",1,2)
AR8 ; Local Surgical Specialty Code & Name
I +LSSC!(LSSN'="") S ^TMP("CSLSUR1",$J,8)=$P(LSS,"^",4)_"^"_LSSN
AR9 ; Operating Room
S OR=$P(SRNODE0,"^",2),JJ=$P($G(^SRS(+OR,0)),"^"),ORN=$G(^SC(+JJ,0))
I +JJ S ^TMP("CSLSUR1",$J,9)=JJ_"^"_$P(ORN,"^")
AR10 ; SPD Comments
S L=0 F S L=$O(^SRF(SRTN,80,L)) Q:'L S X=$G(^SRF(SRTN,80,L,0)) D
.S ^TMP("CSLSUR1",$J,10,L)=X
AR11 ; Hospital
S SPF=$P($G(^SRO(133,+$$SITE^SROUTL0(SRTN),0)),"^")
I +SPF S ^TMP("CSLSUR1",$J,11)=SPF_"^"_$$GET1^DIQ(4,+SPF,.01)
AR12 ; Scheduled by
S SRSP=$P($G(^SRF(SRTN,"1.0")),"^",10)
I +SRSP S ^TMP("CSLSUR1",$J,12)=SRSP_"^"_$P($G(^VA(200,+SRSP,0)),"^")
AR13 ; Entered by
S ^TMP("CSLSUR1",$J,13)=DUZ_"^"_$P($G(^VA(200,+DUZ,0)),"^")
AR14 ; IN/OUT-PATIENT STATUS
I $P(SRNODE0,"^",12)'="" S ^TMP("CSLSUR1",$J,14)=$P(SRNODE0,"^",12)
AR15 ; Time Stamp
D NOW^%DTC S ^TMP("CSLSUR1",$J,15)=%
AR16 ; Attending Surgeon
S ASURG=$P($G(^SRF(SRTN,.1)),"^",13)
I +ASURG S ^TMP("CSLSUR1",$J,16)=ASURG_"^"_$P($G(^VA(200,+ASURG,0)),"^")
;
SEND ; Call CoreFLS API
S DYNOTE=+$$BLDSEG^CSLSUR1(1)
I '$P(SRNODE31,"^",10) S $P(^SRF(SRTN,31),"^",10)=$S(DYNOTE=1:1,1:0)
S SROP=SRTN,SROPER="" D ^SROP1 I SROPER["REQUESTED" S $P(^SRF(SRTN,31),"^",10)=0
EXIT K ^TMP("CSLSUR1",$J)
Q
CHKS(SRDA) ; Calculate checksum of SPD COMMENTS field
N J,L,X,SRCSUM S SRCSUM=0
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
Q SRCSUM
SRSCOR ;B'HAM ISC/SJA - Surgery/CoreFLS API ; [ 12/6/01 8:59 AM ]
+1 ;;3.0; Surgery ;**107,127**;24 Jun 93
+2 ;
+3 ; Reference to $$MOD^ICPTMOD supported by DBIA #1996
+4 ; Reference to $$BLDSEG^CSLSUR1 is supported by DBIA #3498
+5 ; Reference to ^DIC(45.3 is supported by DBIA #218
+6 ; Reference to ^TMP("CSLSUR1" is supported by DBIA #3498
+7 ;
ST(SRTN) SET X="CSLSUR1"
XECUTE ^%ZOSF("TEST")
IF '$TEST
GOTO EXIT
+1 NEW 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
+2 KILL ^TMP("CSLSUR1",$JOB)
+3 SET SRNODE0=$GET(^SRF(SRTN,0))
SET SRNODE30=$GET(^SRF(SRTN,30))
SET SRNODE31=$GET(^SRF(SRTN,31))
AR1 ; Schedule ID
+1 SET ^TMP("CSLSUR1",$JOB,1)=SRTN
AR2 ; Patient ID (DFN) and ICN
+1 SET X="MPIF001"
SET SRICN=""
XECUTE ^%ZOSF("TEST")
IF $TEST
SET SRICN=$$GETICN^MPIF001($PIECE(SRNODE0,"^"))
+2 SET ^TMP("CSLSUR1",$JOB,2)=$PIECE(SRNODE0,"^")_"^"_$SELECT($PIECE(SRICN,"^")=-1:"",1:SRICN)
AR3 ; Type of Action
+1 SET ^TMP("CSLSUR1",$JOB,3)=SRTYPE
+2 ;$S(SRTYPE=1:"NEW",SRTYPE=2:"EDIT",SRTYPE=3:"CANCEL",SRTYPE=4:"DELETE",1:"")
AR4 ; Date/Time of Surgery
+1 SET ^TMP("CSLSUR1",$JOB,4)=$PIECE(SRNODE31,"^",4)_"^"_$PIECE(SRNODE31,"^",5)_"^"_$PIECE(SRNODE0,"^",9)
+2 ;
AR5 ; Principle CPT code & Name
+1 SET SROP=$GET(^SRF(SRTN,"OP"))
SET ^TMP("CSLSUR1",$JOB,5,0)=$PIECE(SROP,"^")
+2 IF +$PIECE(SROP,"^",2)
SET SRICPT=$$CPT^ICPTCOD($PIECE(SROP,"^",2),$PIECE($GET(^SRF(SRTN,0)),"^",9))
SET ^TMP("CSLSUR1",$JOB,5,1)=$PIECE(SRICPT,"^",2)_"^"_$PIECE(SRICPT,"^",3)
+3 ;
+4 ; CPT modifiers for principle code (X = sequential number)
+5 SET PM=0
FOR
SET PM=$ORDER(^SRF(SRTN,"OPMOD",PM))
IF 'PM
QUIT
SET PMIEN=$PIECE($GET(^(PM,0)),"^")
Begin DoDot:1
+6 SET ^TMP("CSLSUR1",$JOB,5,1,PM)=$PIECE($$MOD^ICPTMOD(PMIEN,"I",$PIECE($GET(^SRF(SRTN,0)),"^",9)),"^",2,3)
End DoDot:1
+7 ;
+8 ; Other CPT codes and names (N = value greater than 1)
+9 SET II=0
SET JJ=1
FOR
SET II=$ORDER(^SRF(SRTN,13,II))
IF 'II
QUIT
SET OCIEN=$GET(^(II,2))
Begin DoDot:1
+10 IF +OCIEN
SET OCPT=$$CPT^ICPTCOD(+OCIEN,$PIECE($GET(^SRF(SRTN,0)),"^",9))
SET JJ=JJ+1
SET ^TMP("CSLSUR1",$JOB,5,JJ)=$PIECE(OCPT,"^",2)_"^"_$PIECE(OCPT,"^",3)
+11 ;
+12 ;CPT code modifiers
+13 SET MM=0
FOR
SET MM=$ORDER(^SRF(SRTN,13,II,"MOD",MM))
IF 'MM
QUIT
SET OMIEN=$GET(^SRF(SRTN,13,II,"MOD",MM,0))
SET ^TMP("CSLSUR1",$JOB,5,JJ,MM)=$PIECE($$MOD^ICPTMOD(OMIEN,"I",$PIECE($GET(^SRF(SRTN,0)),"^",9)),"^",2,3)
End DoDot:1
AR6 ; Surgeon ID & Name
+1 SET SURGN=$PIECE($GET(^SRF(SRTN,.1)),"^",4)
+2 IF +SURGN
SET ^TMP("CSLSUR1",$JOB,6)=SURGN_"^"_$PIECE($GET(^VA(200,+SURGN,0)),"^")
AR7 ; Surgical Specialty Code & Name
+1 SET LSSC=+$PIECE(SRNODE0,"^",4)
SET LSS=$GET(^SRO(137.45,LSSC,0))
SET LSSN=$PIECE(LSS,"^")
+2 SET NSSIEN=$PIECE(LSS,"^",2)
+3 IF +NSSIEN
SET ^TMP("CSLSUR1",$JOB,7)=$PIECE($GET(^DIC(45.3,+NSSIEN,0)),"^",1,2)
AR8 ; Local Surgical Specialty Code & Name
+1 IF +LSSC!(LSSN'="")
SET ^TMP("CSLSUR1",$JOB,8)=$PIECE(LSS,"^",4)_"^"_LSSN
AR9 ; Operating Room
+1 SET OR=$PIECE(SRNODE0,"^",2)
SET JJ=$PIECE($GET(^SRS(+OR,0)),"^")
SET ORN=$GET(^SC(+JJ,0))
+2 IF +JJ
SET ^TMP("CSLSUR1",$JOB,9)=JJ_"^"_$PIECE(ORN,"^")
AR10 ; SPD Comments
+1 SET L=0
FOR
SET L=$ORDER(^SRF(SRTN,80,L))
IF 'L
QUIT
SET X=$GET(^SRF(SRTN,80,L,0))
Begin DoDot:1
+2 SET ^TMP("CSLSUR1",$JOB,10,L)=X
End DoDot:1
AR11 ; Hospital
+1 SET SPF=$PIECE($GET(^SRO(133,+$$SITE^SROUTL0(SRTN),0)),"^")
+2 IF +SPF
SET ^TMP("CSLSUR1",$JOB,11)=SPF_"^"_$$GET1^DIQ(4,+SPF,.01)
AR12 ; Scheduled by
+1 SET SRSP=$PIECE($GET(^SRF(SRTN,"1.0")),"^",10)
+2 IF +SRSP
SET ^TMP("CSLSUR1",$JOB,12)=SRSP_"^"_$PIECE($GET(^VA(200,+SRSP,0)),"^")
AR13 ; Entered by
+1 SET ^TMP("CSLSUR1",$JOB,13)=DUZ_"^"_$PIECE($GET(^VA(200,+DUZ,0)),"^")
AR14 ; IN/OUT-PATIENT STATUS
+1 IF $PIECE(SRNODE0,"^",12)'=""
SET ^TMP("CSLSUR1",$JOB,14)=$PIECE(SRNODE0,"^",12)
AR15 ; Time Stamp
+1 DO NOW^%DTC
SET ^TMP("CSLSUR1",$JOB,15)=%
AR16 ; Attending Surgeon
+1 SET ASURG=$PIECE($GET(^SRF(SRTN,.1)),"^",13)
+2 IF +ASURG
SET ^TMP("CSLSUR1",$JOB,16)=ASURG_"^"_$PIECE($GET(^VA(200,+ASURG,0)),"^")
+3 ;
SEND ; Call CoreFLS API
+1 SET DYNOTE=+$$BLDSEG^CSLSUR1(1)
+2 IF '$PIECE(SRNODE31,"^",10)
SET $PIECE(^SRF(SRTN,31),"^",10)=$SELECT(DYNOTE=1:1,1:0)
+3 SET SROP=SRTN
SET SROPER=""
DO ^SROP1
IF SROPER["REQUESTED"
SET $PIECE(^SRF(SRTN,31),"^",10)=0
EXIT KILL ^TMP("CSLSUR1",$JOB)
+1 QUIT
CHKS(SRDA) ; Calculate checksum of SPD COMMENTS field
+1 NEW J,L,X,SRCSUM
SET SRCSUM=0
+2 SET L=0
FOR
SET L=$ORDER(^SRF(SRDA,80,L))
IF 'L
QUIT
SET X=^SRF(SRDA,80,L,0)
FOR J=1:1:$LENGTH(X)
SET SRCSUM=L*J*$ASCII(X,J)+SRCSUM
+3 QUIT SRCSUM
