SRHLUO ;B'HAM ISC/DLR - Surgery Interface Utilities for building Outgoing HL7 Segment ; [ 05/06/98 7:14 AM ]
;;3.0; Surgery ;**41,127**;24 Jun 93
; Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
; ** ASSUMMED variable list
; all - INIT^HLTRANS
; DFN - IEN file #2
; SRI - incremental variable ^TMP("HLS",$J,SRI)
; - returns the next #
; CASE- IEN (file 130) case number must be set before the call
;
AL1(SRI,SRENT) ;AL1 segment(s) - allergy information from the generic call to (GMRADPT)
Q:'$D(DFN)
S X="GMRADPT" X ^%ZOSF("TEST") Q:'$T
N TYPE,X,AL1,CNT
;Allergy package valid entry point returns GMRAL(x)
D ^GMRADPT
S CNT=1
F X=0:0 S X=$O(GMRAL(X)) Q:X'>0 D
.S TYPE=$P(GMRAL(X),"^",3),AL1(X)="AL1"_HL("FS")_$E("0000",$L(CNT)+1,4)_CNT_HL("FS")_$S(TYPE="D":"DA",TYPE="F":"FA",TYPE="O":"MA",1:"")_HL("FS")_HLCOMP_$P(GMRAL(X),"^",2)
.S ^TMP(SRENT,$J,SRI)=AL1(X),SRI=SRI+1,CNT=CNT+1
K GMRAL
Q
DG1(SRI,SRENT) ;DG1 segment(s) - surgery diagnosis information
Q:'$D(CASE)
N DG1,I9,X,X1
I $D(^SRF(CASE,34)) I $P(^SRF(CASE,34),U,2)'="" D
.S I9=$$ICDDX^ICDCODE($P(^SRF(CASE,34),U,2),$P($G(^SRF(CASE,0)),"^",9))
.S DG1="DG1"_HL("FS")_"0001"_HL("FS")_"I9"_HL("FS")_$P(I9,U,2)_HL("FS")_$P(I9,U,4)_HL("FS")_HL("FS")_"P" D
..S ^TMP("HLS",$J,SRI)=DG1,SRI=SRI+1,DG1=""
I $D(^SRF(CASE,33)) I $P(^SRF(CASE,33),U)'="" S DG1="DG1"_HL("FS")_"0001"_HL("FS")_"I9"_HL("FS")_HL("FS")_$P(^SRF(CASE,33),U)_HL("FS")_HL("FS")_"PR" D
.S ^TMP("HLS",$J,SRI)=DG1,SRI=SRI+1,DG1=""
I $D(^SRF(CASE,14,0)) S X1=2 F X=0:0 S X=$O(^SRF(CASE,14,X)) Q:X'>0 D
.I $P(^(0),U,3) S I9=$$ICDDX^ICDCODE($P(^SRF(CASE,14,0),U,3),$P($G(^SRF(CASE,0)),"^",9)) D
..S ^TMP("HLS",$J,SRI)="DG1"_HL("FS")_$E("0000",$L(X1)+1,4)_X1_HL("FS")_"I9"_HL("FS")_$P(I9,U,2)_HL("FS")_$P(I9,U,4)_HL("FS")_HL("FS")_"PR",X1=X1+1,SRI=SRI+1
Q
ERR(SRI,SRERR) ;ERR segment
; SRERR = AE error code and location (segment^sequence #^field^error)
S ^TMP("HLA",$J,SRI)="ERR"_HL("FS")_$G(SRERR(1))_HLCOMP_$G(SRERR(2))_HLCOMP_$G(SRERR),SRI=SRI+1
Q
MSA(SRI,SRAC) ;MSA segment
; SRAC = Acknowledgement code (ID)
; AA = Application Accepted (responsed with information)
; AE = Application Error (bad data send error response)
; AR = Application Reject (no data in date range ... )
;
N MSA
S MSA(1)=$G(SRAC),MSA(2)=$G(HL("MID")),MSA(3)=$G(SRERR)
S ^TMP("HLA",$J,SRI)="MSA"_HL("FS") F XX=1:1:3 S ^TMP("HLA",$J,SRI)=$G(^TMP("HLA",$J,SRI))_$G(MSA(XX))_$S(XX=3:"",1:HL("FS"))
S SRI=SRI+1
Q
OBX(SRI,SRENT) ;OBX segment(s)
; This segment builds OBX segments for the following Preoperative data
; - vitals\measurements ^GMRVUTL routine:
; height, weight, blood pressure, pulse rate, and temperature
; - IN\OUT-PATIENT STATUS field in File #130
; - CANCEL DATE and CANCEL REASON for cancelled and aborted cases
; - SURGICAL SPECIALTY (OR) or MEDICAL SPECIALTY (NON OR)
; - SURGEON PGY and ANES SUPERVISE CODE
Q:'$D(CASE)
N OBX,CNT,TYPE,X,Y
S CNT=1
I $D(^SRF(CASE,"NON")) S OBX(2)="CE",OBX(3)=HLCOMP_"MEDICAL SPECIALTY"_HLCOMP,OBX(5)=$P(^("NON"),U,8) I OBX(5)'="" S OBX(5)=HLCOMP_$P(^ECC(723,OBX(5),0),U)_HLCOMP_"99VA723" D SOBX
I $P(^SRF(CASE,0),U,4)'="" S OBX(2)="CE",OBX(3)=HLCOMP_"SURGICAL SPECIALTY"_HLCOMP,OBX(5)=$P(^(0),U,4) I OBX(5)'="" S OBX(5)=HLCOMP_$P(^SRO(137.45,OBX(5),0),U)_HLCOMP_"99VA137.45" D SOBX
I $D(^SRF(CASE,200)) I $P(^SRF(CASE,200),U,52)'="" S OBX(2)="NM",OBX(3)=HLCOMP_"SURGEON PGY"_HLCOMP_"L",OBX(5)=$P(^(200),U,52) D SOBX
I $D(^SRF(CASE,.3)) I $P(^SRF(CASE,.3),U,6)'="" S OBX(2)="CE",OBX(3)=HLCOMP_"ANES SUPERVISE CODE"_HLCOMP_"L",OBX(5)=$P(^(.3),U,6) D SOBX
I $P(^SRF(CASE,0),U,12)'="" S OBX(2)="CE",OBX(3)=HLCOMP_"PATIENT CLASS"_HLCOMP,OBX(5)=$P(^(0),U,12) S C=$P(^DD(130,.011,0),U,2),Y=OBX(5) D Y^DIQ S OBX(5)=HLCOMP_Y_HLCOMP_"L" D SOBX
S X="GMRVUTL" X ^%ZOSF("TEST") I $T F TYPE="BP","HT","WT","T","P" S GMRVSTR=TYPE D EN6^GMRVUTL I $G(X)'="" S X1=$P(X,"^"),X2=60,SRX=X D C^%DTC I X'<DT D
.S OBX(2)="CE",OBX(5)=$P(SRX,"^",8),OBX(11)="S",OBX(14)=$$HLDATE^HLFNC($P(SRX,"^")),OBX(16)=$$HNAME^SRHLU($P(SRX,U,6))
.I TYPE="BP" S OBX(3)="1002"_HLCOMP_"BP",OBX(5)=$P(SRX,"^",8) D SOBX
.I TYPE="HT" S OBX(3)="1010.3"_HLCOMP_"Height",OBX(5)=$J(2.54*OBX(5),0,2),OBX(6)="cm" D SOBX
.I TYPE="WT" S OBX(3)="1010.1"_HLCOMP_"Body Weight",OBX(5)=$J(OBX(5)/2.2,0,2),OBX(6)="kg" D SOBX
.I TYPE="T" S OBX(3)="1000"_HLCOMP_"Temperature" S OBX(5)=$J(OBX(5)-32*5/9,0,2),OBX(6)="cel" D SOBX
.I TYPE="P" S OBX(3)="1006.2"_HLCOMP_"HR",OBX(6)="min" D SOBX
I $D(^SRF(CASE,30)),$P($G(^SRF(CASE,31)),U,8)'="" D
.S OBX(2)="CE",OBX(3)=HLCOMP_"CANCEL REASON"_HLCOMP_"L",OBX(5)=HLCOMP_$P(^SRO(135,$P(^SRF(CASE,31),U,8),0),U)_HLCOMP_"L",OBX(14)=$$HLDATE^HLFNC($P(^SRF(CASE,30),U)),OBX(16)=$$HNAME^SRHLU($P(^SRF(CASE,30),U,3)) D SOBX
Q
SOBX ;sets the OBX segment
S OBX(11)="S"
S OBX(1)=CNT
S ^TMP(SRENT,$J,SRI)="OBX"_HL("FS") F XX=1:1:16 S ^TMP(SRENT,$J,SRI)=$G(^TMP(SRENT,$J,SRI))_$G(OBX(XX))_$S(XX=16:"",1:HL("FS")),OBX(XX)=""
S SRI=SRI+1,CNT=$G(CNT)+1
Q
PID(SRI,SRENT) ;PID segment builder returns patient information
Q:'$D(DFN)
N PID
S ^TMP(SRENT,$J,SRI)=$$EN^VAFHLPID(DFN,"1,2,3,4,5,6,7,8,10,11,13,16,17,19",1)
S SRI=SRI+1
Q
SRHLUO ;B'HAM ISC/DLR - Surgery Interface Utilities for building Outgoing HL7 Segment ; [ 05/06/98 7:14 AM ]
+1 ;;3.0; Surgery ;**41,127**;24 Jun 93
+2 ; Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
+3 ; ** ASSUMMED variable list
+4 ; all - INIT^HLTRANS
+5 ; DFN - IEN file #2
+6 ; SRI - incremental variable ^TMP("HLS",$J,SRI)
+7 ; - returns the next #
+8 ; CASE- IEN (file 130) case number must be set before the call
+9 ;
AL1(SRI,SRENT) ;AL1 segment(s) - allergy information from the generic call to (GMRADPT)
+1 IF '$DATA(DFN)
QUIT
+2 SET X="GMRADPT"
XECUTE ^%ZOSF("TEST")
IF '$TEST
QUIT
+3 NEW TYPE,X,AL1,CNT
+4 ;Allergy package valid entry point returns GMRAL(x)
+5 DO ^GMRADPT
+6 SET CNT=1
+7 FOR X=0:0
SET X=$ORDER(GMRAL(X))
IF X'>0
QUIT
Begin DoDot:1
+8 SET TYPE=$PIECE(GMRAL(X),"^",3)
SET AL1(X)="AL1"_HL("FS")_$EXTRACT("0000",$LENGTH(CNT)+1,4)_CNT_HL("FS")_$SELECT(TYPE="D":"DA",TYPE="F":"FA",TYPE="O":"MA",1:"")_HL("FS")_HLCOMP_$PIECE(GMRAL(X),"^",2)
+9 SET ^TMP(SRENT,$JOB,SRI)=AL1(X)
SET SRI=SRI+1
SET CNT=CNT+1
End DoDot:1
+10 KILL GMRAL
+11 QUIT
DG1(SRI,SRENT) ;DG1 segment(s) - surgery diagnosis information
+1 IF '$DATA(CASE)
QUIT
+2 NEW DG1,I9,X,X1
+3 IF $DATA(^SRF(CASE,34))
IF $PIECE(^SRF(CASE,34),U,2)'=""
Begin DoDot:1
+4 SET I9=$$ICDDX^ICDCODE($PIECE(^SRF(CASE,34),U,2),$PIECE($GET(^SRF(CASE,0)),"^",9))
+5 SET DG1="DG1"_HL("FS")_"0001"_HL("FS")_"I9"_HL("FS")_$PIECE(I9,U,2)_HL("FS")_$PIECE(I9,U,4)_HL("FS")_HL("FS")_"P"
Begin DoDot:2
+6 SET ^TMP("HLS",$JOB,SRI)=DG1
SET SRI=SRI+1
SET DG1=""
End DoDot:2
End DoDot:1
+7 IF $DATA(^SRF(CASE,33))
IF $PIECE(^SRF(CASE,33),U)'=""
SET DG1="DG1"_HL("FS")_"0001"_HL("FS")_"I9"_HL("FS")_HL("FS")_$PIECE(^SRF(CASE,33),U)_HL("FS")_HL("FS")_"PR"
Begin DoDot:1
+8 SET ^TMP("HLS",$JOB,SRI)=DG1
SET SRI=SRI+1
SET DG1=""
End DoDot:1
+9 IF $DATA(^SRF(CASE,14,0))
SET X1=2
FOR X=0:0
SET X=$ORDER(^SRF(CASE,14,X))
IF X'>0
QUIT
Begin DoDot:1
+10 IF $PIECE(^(0),U,3)
SET I9=$$ICDDX^ICDCODE($PIECE(^SRF(CASE,14,0),U,3),$PIECE($GET(^SRF(CASE,0)),"^",9))
Begin DoDot:2
+11 SET ^TMP("HLS",$JOB,SRI)="DG1"_HL("FS")_$EXTRACT("0000",$LENGTH(X1)+1,4)_X1_HL("FS")_"I9"_HL("FS")_$PIECE(I9,U,2)_HL("FS")_$PIECE(I9,U,4)_HL("FS")_HL("FS")_"PR"
SET X1=X1+1
SET SRI=SRI+1
End DoDot:2
End DoDot:1
+12 QUIT
ERR(SRI,SRERR) ;ERR segment
+1 ; SRERR = AE error code and location (segment^sequence #^field^error)
+2 SET ^TMP("HLA",$JOB,SRI)="ERR"_HL("FS")_$GET(SRERR(1))_HLCOMP_$GET(SRERR(2))_HLCOMP_$GET(SRERR)
SET SRI=SRI+1
+3 QUIT
MSA(SRI,SRAC) ;MSA segment
+1 ; SRAC = Acknowledgement code (ID)
+2 ; AA = Application Accepted (responsed with information)
+3 ; AE = Application Error (bad data send error response)
+4 ; AR = Application Reject (no data in date range ... )
+5 ;
+6 NEW MSA
+7 SET MSA(1)=$GET(SRAC)
SET MSA(2)=$GET(HL("MID"))
SET MSA(3)=$GET(SRERR)
+8 SET ^TMP("HLA",$JOB,SRI)="MSA"_HL("FS")
FOR XX=1:1:3
SET ^TMP("HLA",$JOB,SRI)=$GET(^TMP("HLA",$JOB,SRI))_$GET(MSA(XX))_$SELECT(XX=3:"",1:HL("FS"))
+9 SET SRI=SRI+1
+10 QUIT
OBX(SRI,SRENT) ;OBX segment(s)
+1 ; This segment builds OBX segments for the following Preoperative data
+2 ; - vitals\measurements ^GMRVUTL routine:
+3 ; height, weight, blood pressure, pulse rate, and temperature
+4 ; - IN\OUT-PATIENT STATUS field in File #130
+5 ; - CANCEL DATE and CANCEL REASON for cancelled and aborted cases
+6 ; - SURGICAL SPECIALTY (OR) or MEDICAL SPECIALTY (NON OR)
+7 ; - SURGEON PGY and ANES SUPERVISE CODE
+8 IF '$DATA(CASE)
QUIT
+9 NEW OBX,CNT,TYPE,X,Y
+10 SET CNT=1
+11 IF $DATA(^SRF(CASE,"NON"))
SET OBX(2)="CE"
SET OBX(3)=HLCOMP_"MEDICAL SPECIALTY"_HLCOMP
SET OBX(5)=$PIECE(^("NON"),U,8)
IF OBX(5)'=""
SET OBX(5)=HLCOMP_$PIECE(^ECC(723,OBX(5),0),U)_HLCOMP_"99VA723"
DO SOBX
+12 IF $PIECE(^SRF(CASE,0),U,4)'=""
SET OBX(2)="CE"
SET OBX(3)=HLCOMP_"SURGICAL SPECIALTY"_HLCOMP
SET OBX(5)=$PIECE(^(0),U,4)
IF OBX(5)'=""
SET OBX(5)=HLCOMP_$PIECE(^SRO(137.45,OBX(5),0),U)_HLCOMP_"99VA137.45"
DO SOBX
+13 IF $DATA(^SRF(CASE,200))
IF $PIECE(^SRF(CASE,200),U,52)'=""
SET OBX(2)="NM"
SET OBX(3)=HLCOMP_"SURGEON PGY"_HLCOMP_"L"
SET OBX(5)=$PIECE(^(200),U,52)
DO SOBX
+14 IF $DATA(^SRF(CASE,.3))
IF $PIECE(^SRF(CASE,.3),U,6)'=""
SET OBX(2)="CE"
SET OBX(3)=HLCOMP_"ANES SUPERVISE CODE"_HLCOMP_"L"
SET OBX(5)=$PIECE(^(.3),U,6)
DO SOBX
+15 IF $PIECE(^SRF(CASE,0),U,12)'=""
SET OBX(2)="CE"
SET OBX(3)=HLCOMP_"PATIENT CLASS"_HLCOMP
SET OBX(5)=$PIECE(^(0),U,12)
SET C=$PIECE(^DD(130,.011,0),U,2)
SET Y=OBX(5)
DO Y^DIQ
SET OBX(5)=HLCOMP_Y_HLCOMP_"L"
DO SOBX
+16 SET X="GMRVUTL"
XECUTE ^%ZOSF("TEST")
IF $TEST
FOR TYPE="BP","HT","WT","T","P"
SET GMRVSTR=TYPE
DO EN6^GMRVUTL
IF $GET(X)'=""
SET X1=$PIECE(X,"^")
SET X2=60
SET SRX=X
DO C^%DTC
IF X'<DT
Begin DoDot:1
+17 SET OBX(2)="CE"
SET OBX(5)=$PIECE(SRX,"^",8)
SET OBX(11)="S"
SET OBX(14)=$$HLDATE^HLFNC($PIECE(SRX,"^"))
SET OBX(16)=$$HNAME^SRHLU($PIECE(SRX,U,6))
+18 IF TYPE="BP"
SET OBX(3)="1002"_HLCOMP_"BP"
SET OBX(5)=$PIECE(SRX,"^",8)
DO SOBX
+19 IF TYPE="HT"
SET OBX(3)="1010.3"_HLCOMP_"Height"
SET OBX(5)=$JUSTIFY(2.54*OBX(5),0,2)
SET OBX(6)="cm"
DO SOBX
+20 IF TYPE="WT"
SET OBX(3)="1010.1"_HLCOMP_"Body Weight"
SET OBX(5)=$JUSTIFY(OBX(5)/2.2,0,2)
SET OBX(6)="kg"
DO SOBX
+21 IF TYPE="T"
SET OBX(3)="1000"_HLCOMP_"Temperature"
SET OBX(5)=$JUSTIFY(OBX(5)-32*5/9,0,2)
SET OBX(6)="cel"
DO SOBX
+22 IF TYPE="P"
SET OBX(3)="1006.2"_HLCOMP_"HR"
SET OBX(6)="min"
DO SOBX
End DoDot:1
+23 IF $DATA(^SRF(CASE,30))
IF $PIECE($GET(^SRF(CASE,31)),U,8)'=""
Begin DoDot:1
+24 SET OBX(2)="CE"
SET OBX(3)=HLCOMP_"CANCEL REASON"_HLCOMP_"L"
SET OBX(5)=HLCOMP_$PIECE(^SRO(135,$PIECE(^SRF(CASE,31),U,8),0),U)_HLCOMP_"L"
SET OBX(14)=$$HLDATE^HLFNC($PIECE(^SRF(CASE,30),U))
SET OBX(16)=$$HNAME^SRHLU($PIECE(^SRF(CASE,30),U,3))
DO SOBX
End DoDot:1
+25 QUIT
SOBX ;sets the OBX segment
+1 SET OBX(11)="S"
+2 SET OBX(1)=CNT
+3 SET ^TMP(SRENT,$JOB,SRI)="OBX"_HL("FS")
FOR XX=1:1:16
SET ^TMP(SRENT,$JOB,SRI)=$GET(^TMP(SRENT,$JOB,SRI))_$GET(OBX(XX))_$SELECT(XX=16:"",1:HL("FS"))
SET OBX(XX)=""
+4 SET SRI=SRI+1
SET CNT=$GET(CNT)+1
+5 QUIT
PID(SRI,SRENT) ;PID segment builder returns patient information
+1 IF '$DATA(DFN)
QUIT
+2 NEW PID
+3 SET ^TMP(SRENT,$JOB,SRI)=$$EN^VAFHLPID(DFN,"1,2,3,4,5,6,7,8,10,11,13,16,17,19",1)
+4 SET SRI=SRI+1
+5 QUIT
