OCXOHL7 ;SLC/RJS,CLA - External Interface - PROCESS HL7 DATA ARRAY ;4/02/03 13:50
;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,179**;Dec 17,1997
;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
;
;
Q
SILENT(OCXMSG,OUTMSG) ;
;
N OCXSEG0,OCXRDT,OCXHL7,OCXOZZT
S OCXRDT=($H*86400+$P($H,",",2))
S:'$D(OUTMSG) OUTMSG=""
D CHECK(.OCXMSG,.OUTMSG)
Q
;
VERBOSE(OCXMSG) ;
;
N OCXSEG0,OCXX,OUTMSG,OCXHL7,OCXOZZT
S OCXRDT=($H*86400+$P($H,",",2))
S OUTMSG=""
D CHECK(.OCXMSG,.OUTMSG)
W:$O(OUTMSG(0)) !,"Order Check Message: ",$C(7)
S OCXX=0 F S OCXX=$O(OUTMSG(OCXX)) Q:'OCXX W !,OUTMSG(OCXX)
W:$O(OUTMSG(0)) !,$C(7)
Q
;
CHECK(OCXMSG,OUTMSG) ;
;
N OCXARY,OCXDFN,OCXEL,OCXODATA,OCXOLOG,OCXOSRC,OCXDSIZE
N OCXOTIME,OCXQUIT,OCXSEG0,OCXSEQ,OCXSUB,OCXTEST,OCXVAR
;
I $$RTEST D Q
.N OMSG,OTMOUT,OCXM
.S OMSG="^25^^Order Checking is recompiling and momentarily disabled"
.S OCXM=0 F S OCXM=$O(OUTMSG(OCXM)) Q:'OCXM Q:(OUTMSG(OCXM)[OMSG)
.Q:OCXM
.S OUTMSG($O(OUTMSG(""),-1)+1)=OMSG
;
S OCXARY=$S($L($G(OCXMSG)):OCXMSG,1:"OCXMSG") Q:'$O(@OCXARY@(0))
;
S (OCXQUIT,OCXSUB)=0 F S OCXSUB=$O(@OCXARY@(OCXSUB)) Q:'OCXSUB I ($P($G(@OCXARY@(OCXSUB)),"|",1)="ORC") D Q
.S:($P($P($G(@OCXARY@(OCXSUB)),"|",2),"^",1)="ZC") OCXQUIT=1
;
Q:OCXQUIT
;
S OCXOLOG=$$LOG(OCXARY)
;
S OCXODATA="",OCXTEST=$G(OCXOVRD)
;
S OCXVAR("DUZ")=""
S OCXVAR("OCXMSG")=""
S OCXVAR("OCXARY")=""
S OCXOSRC="GENERIC HL7 MESSAGE ARRAY"
;
S OCXSUB=0 F S OCXSUB=$O(@OCXARY@(OCXSUB)) Q:'OCXSUB D
.N OCXLINE,OCXPC,X,OCXTDAT,OCXCLIN,LASTPC
.S OCXDSIZE=$$ARYSIZE($NAME(@OCXARY@(OCXSUB)))
.;
.I (OCXDSIZE<5000) D Q:'$L($G(OCXLINE(0)))
..M OCXLINE(0)=@OCXARY@(OCXSUB)
..S OCXLINE(0,0)=OCXLINE(0) ; This will make first node consistent with continuation lines.
..S OCXSEG=$P($G(OCXLINE(0)),"|",1)
.;
.I (OCXDSIZE>4999) D Q:'$L($G(^TMP($J,"OCXLDATA",0)))
..K ^TMP($J,"OCXLDATA")
..M ^TMP($J,"OCXLDATA",0)=@OCXARY@(OCXSUB)
..S ^TMP($J,"OCXLDATA",0,0)=^TMP($J,"OCXLDATA",0) ; This will make first node consistent with continuation lines.
..S OCXSEG=$P($G(^TMP($J,"OCXLDATA",0)),"|",1)
.;
.Q:'$L(OCXSEG)
.;
.I $D(OCXODATA(OCXSEG)) D ; This is another instance of this segment.
..; Process current OCXODATA and reset OCXODATA for this new instance.
..; Process OCXODATA
..S OCXDFN=$$GETDFN(OCXARY) I $G(OCXDFN) D UPDATE^OCXOZ01(+OCXDFN,OCXOSRC,.OUTMSG)
..;
..; Reset OCXODATA
..S OCXSEQ=+$G(OCXODATA(OCXSEG)) F Q:'OCXSEQ D S OCXSEQ=$O(OCXODATA(OCXSEQ))
...S OCXSEG0=$G(OCXODATA(OCXSEQ)) Q:'$L(OCXSEG0)
...K OCXODATA(OCXSEQ),OCXODATA(OCXSEG0)
.;
.S OCXODATA(OCXSUB)=OCXSEG ; Set OCXODATA 'cross reference'
.S OCXODATA(OCXSEG)=OCXSUB ; Set OCXODATA 'cross reference'
.;
.; Load this segment instance into OCXODATA
.;
.; OCXPC - Keeps track of which "|" piece we're on
.;
.I (OCXDSIZE<5000) D LOADATA(OCXSEG,"OCXLINE(0)")
.;
.I (OCXDSIZE>4999) D LOADATA(OCXSEG,$NAME(^TMP($J,"OCXLDATA",0)))
;
S OCXDFN=$$GETDFN(OCXARY)
I $G(OCXDFN) D UPDATE^OCXOZ01(+OCXDFN,OCXOSRC,.OUTMSG) I 1 ; Process OCXODATA for the last segment
;
D FINISH^OCXOLOG(OCXOLOG)
;
K ^TMP($J,"OCXLDATA")
;
Q
;
LOADATA(OCXSEG,OCXSD) ; Get '|' piece #OCXPC of OCXSD Segment Data array.
;
N OCXTEXT,OCXPCNT,OCXD0,OCXD1
;
Q:'$L(OCXSEG)
S OCXPCNT=0,OCXD0="" F S OCXD0=$O(@OCXSD@(OCXD0)) Q:'$L(OCXD0) D
.S OCXTEXT=$G(@OCXSD@(OCXD0))
.F OCXD1=1:1:$L(OCXTEXT) D
..I ($E(OCXTEXT,OCXD1)="|") S OCXPCNT=OCXPCNT+1 Q
..I ($L($G(OCXODATA(OCXSEG,OCXPCNT)))<241) S OCXODATA(OCXSEG,OCXPCNT)=$G(OCXODATA(OCXSEG,OCXPCNT))_$E(OCXTEXT,OCXD1)
;
Q
;
RTEST() ; Does ^OCXOZ01 exist ?? Is it currently being compiled ??
N DATE,TMOUT
Q:'$L($T(^OCXOZ01)) 1
I '($P($G(^OCXD(861,1,0)),U,1)="SITE PREFERENCES") K ^OCXD(861,1) S ^OCXD(861,1,0)="SITE PREFERENCES"
S DATE=$P($G(^OCXD(861,1,0)),U,3)
I DATE,((+DATE)=(+$H)),(((+$P($H,",",2))-(+$P(DATE,",",2)))<1800) Q 1
Q 0
;
LOG(OCXARY) ;
; Log Data Messages
;
I $G(OCXTRACE),$$CDATA^OCXOZ01 W:$G(OCXTRACE) !," Raw Input Data: ",! D ZW(OCXARY) Q 0
Q:'$L($T(LOG^OCXOZ01)) 0 Q:'$$LOG^OCXOZ01 0
N OCXDFN,OCXNL
I '$O(@OCXARY@(0)) S OCXARY="OCXNL",OCXNL(1)="Null HL7 Data Array Found"
S OCXDFN=$$GETDFN(OCXARY)
Q $$NEW^OCXOLOG(OCXARY,"HL7",+$G(DUZ),+OCXDFN)
;
ARYSIZE(ARY) ; Get array size (Local or Global)
;
N ARY1,SIZE
;
S SIZE=0
;
I '(ARY["^") F S ARY=$Q(@ARY) Q:'$L(ARY) S SIZE=SIZE+$L(@ARY)
;
I (ARY["^") D
.S ARY=$NAME(@ARY),ARY1=ARY
.S:($E(ARY,$L(ARY))=")") ARY=$E(ARY,1,$L(ARY)-1)_","
.F S ARY1=$Q(@ARY1) Q:'$L(ARY1) Q:'(ARY1[ARY) S SIZE=SIZE+$L(@ARY1)
;
Q SIZE
;
ZW(ARY) ; ZWrite an array (Local or Global)
;
N ARY1
;
I '(ARY["^") D Q
.F S ARY=$Q(@ARY) Q:'$L(ARY) W !,ARY," = ",@ARY
;
I (ARY["^") D Q
.S ARY=$NAME(@ARY),ARY1=ARY
.S:($E(ARY,$L(ARY))=")") ARY=$E(ARY,1,$L(ARY)-1)_","
.F S ARY1=$Q(@ARY1) Q:'$L(ARY1) Q:'(ARY1[ARY) W !,ARY1," = ",@ARY1
;
Q
;
ERROR Q
;
; **** Old Labels to insure backwards compatibility ****
;
;
GETDFN(ARRAY) ; Returns the patient IEN from file 2.
;
N OCXNDX,OCXARY,OCXP1,OCXP2,OCXP3
S OCXARY=$S($L($G(ARRAY)):ARRAY,1:"ARRAY")
S OCXNDX=0 F S OCXNDX=$O(@OCXARY@(OCXNDX)) Q:'OCXNDX I $P($G(@OCXARY@(OCXNDX)),"|",1)="PID" Q
Q:'OCXNDX 0
;
S OCXP1=$P($G(@OCXARY@(OCXNDX)),"|",4)
S OCXP2=$P($G(@OCXARY@(OCXNDX)),"|",5)
S OCXP3=$P($G(@OCXARY@(OCXNDX)),"|",6)
;
Q:(OCXP2["DPT(") +OCXP2
;
I $L(OCXP3),($P($G(^DPT(+OCXP1,0)),U,1)=OCXP3) Q +OCXP1
;
Q 0
;
; Old line label area.
;
PROC(OCXMSG,OUTMSG) ;
D SILENT(.OCXMSG,.OUTMSG)
Q
;
EN(OCXMSG) ;
D VERBOSE(.OCXMSG)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOCXOHL7 5758 printed Dec 13, 2024@02:25:38 Page 2
OCXOHL7 ;SLC/RJS,CLA - External Interface - PROCESS HL7 DATA ARRAY ;4/02/03 13:50
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,179**;Dec 17,1997
+2 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
+3 ;
+4 ;
+5 QUIT
SILENT(OCXMSG,OUTMSG) ;
+1 ;
+2 NEW OCXSEG0,OCXRDT,OCXHL7,OCXOZZT
+3 SET OCXRDT=($HOROLOG*86400+$PIECE($HOROLOG,",",2))
+4 if '$DATA(OUTMSG)
SET OUTMSG=""
+5 DO CHECK(.OCXMSG,.OUTMSG)
+6 QUIT
+7 ;
VERBOSE(OCXMSG) ;
+1 ;
+2 NEW OCXSEG0,OCXX,OUTMSG,OCXHL7,OCXOZZT
+3 SET OCXRDT=($HOROLOG*86400+$PIECE($HOROLOG,",",2))
+4 SET OUTMSG=""
+5 DO CHECK(.OCXMSG,.OUTMSG)
+6 if $ORDER(OUTMSG(0))
WRITE !,"Order Check Message: ",$CHAR(7)
+7 SET OCXX=0
FOR
SET OCXX=$ORDER(OUTMSG(OCXX))
if 'OCXX
QUIT
WRITE !,OUTMSG(OCXX)
+8 if $ORDER(OUTMSG(0))
WRITE !,$CHAR(7)
+9 QUIT
+10 ;
CHECK(OCXMSG,OUTMSG) ;
+1 ;
+2 NEW OCXARY,OCXDFN,OCXEL,OCXODATA,OCXOLOG,OCXOSRC,OCXDSIZE
+3 NEW OCXOTIME,OCXQUIT,OCXSEG0,OCXSEQ,OCXSUB,OCXTEST,OCXVAR
+4 ;
+5 IF $$RTEST
Begin DoDot:1
+6 NEW OMSG,OTMOUT,OCXM
+7 SET OMSG="^25^^Order Checking is recompiling and momentarily disabled"
+8 SET OCXM=0
FOR
SET OCXM=$ORDER(OUTMSG(OCXM))
if 'OCXM
QUIT
if (OUTMSG(OCXM)[OMSG)
QUIT
+9 if OCXM
QUIT
+10 SET OUTMSG($ORDER(OUTMSG(""),-1)+1)=OMSG
End DoDot:1
QUIT
+11 ;
+12 SET OCXARY=$SELECT($LENGTH($GET(OCXMSG)):OCXMSG,1:"OCXMSG")
if '$ORDER(@OCXARY@(0))
QUIT
+13 ;
+14 SET (OCXQUIT,OCXSUB)=0
FOR
SET OCXSUB=$ORDER(@OCXARY@(OCXSUB))
if 'OCXSUB
QUIT
IF ($PIECE($GET(@OCXARY@(OCXSUB)),"|",1)="ORC")
Begin DoDot:1
+15 if ($PIECE($PIECE($GET(@OCXARY@(OCXSUB)),"|",2),"^",1)="ZC")
SET OCXQUIT=1
End DoDot:1
QUIT
+16 ;
+17 if OCXQUIT
QUIT
+18 ;
+19 SET OCXOLOG=$$LOG(OCXARY)
+20 ;
+21 SET OCXODATA=""
SET OCXTEST=$GET(OCXOVRD)
+22 ;
+23 SET OCXVAR("DUZ")=""
+24 SET OCXVAR("OCXMSG")=""
+25 SET OCXVAR("OCXARY")=""
+26 SET OCXOSRC="GENERIC HL7 MESSAGE ARRAY"
+27 ;
+28 SET OCXSUB=0
FOR
SET OCXSUB=$ORDER(@OCXARY@(OCXSUB))
if 'OCXSUB
QUIT
Begin DoDot:1
+29 NEW OCXLINE,OCXPC,X,OCXTDAT,OCXCLIN,LASTPC
+30 SET OCXDSIZE=$$ARYSIZE($NAME(@OCXARY@(OCXSUB)))
+31 ;
+32 IF (OCXDSIZE<5000)
Begin DoDot:2
+33 MERGE OCXLINE(0)=@OCXARY@(OCXSUB)
+34 ; This will make first node consistent with continuation lines.
SET OCXLINE(0,0)=OCXLINE(0)
+35 SET OCXSEG=$PIECE($GET(OCXLINE(0)),"|",1)
End DoDot:2
if '$LENGTH($GET(OCXLINE(0)))
QUIT
+36 ;
+37 IF (OCXDSIZE>4999)
Begin DoDot:2
+38 KILL ^TMP($JOB,"OCXLDATA")
+39 MERGE ^TMP($JOB,"OCXLDATA",0)=@OCXARY@(OCXSUB)
+40 ; This will make first node consistent with continuation lines.
SET ^TMP($JOB,"OCXLDATA",0,0)=^TMP($JOB,"OCXLDATA",0)
+41 SET OCXSEG=$PIECE($GET(^TMP($JOB,"OCXLDATA",0)),"|",1)
End DoDot:2
if '$LENGTH($GET(^TMP($JOB,"OCXLDATA",0)))
QUIT
+42 ;
+43 if '$LENGTH(OCXSEG)
QUIT
+44 ;
+45 ; This is another instance of this segment.
IF $DATA(OCXODATA(OCXSEG))
Begin DoDot:2
+46 ; Process current OCXODATA and reset OCXODATA for this new instance.
+47 ; Process OCXODATA
+48 SET OCXDFN=$$GETDFN(OCXARY)
IF $GET(OCXDFN)
DO UPDATE^OCXOZ01(+OCXDFN,OCXOSRC,.OUTMSG)
+49 ;
+50 ; Reset OCXODATA
+51 SET OCXSEQ=+$GET(OCXODATA(OCXSEG))
FOR
if 'OCXSEQ
QUIT
Begin DoDot:3
+52 SET OCXSEG0=$GET(OCXODATA(OCXSEQ))
if '$LENGTH(OCXSEG0)
QUIT
+53 KILL OCXODATA(OCXSEQ),OCXODATA(OCXSEG0)
End DoDot:3
SET OCXSEQ=$ORDER(OCXODATA(OCXSEQ))
End DoDot:2
+54 ;
+55 ; Set OCXODATA 'cross reference'
SET OCXODATA(OCXSUB)=OCXSEG
+56 ; Set OCXODATA 'cross reference'
SET OCXODATA(OCXSEG)=OCXSUB
+57 ;
+58 ; Load this segment instance into OCXODATA
+59 ;
+60 ; OCXPC - Keeps track of which "|" piece we're on
+61 ;
+62 IF (OCXDSIZE<5000)
DO LOADATA(OCXSEG,"OCXLINE(0)")
+63 ;
+64 IF (OCXDSIZE>4999)
DO LOADATA(OCXSEG,$NAME(^TMP($JOB,"OCXLDATA",0)))
End DoDot:1
+65 ;
+66 SET OCXDFN=$$GETDFN(OCXARY)
+67 ; Process OCXODATA for the last segment
IF $GET(OCXDFN)
DO UPDATE^OCXOZ01(+OCXDFN,OCXOSRC,.OUTMSG)
IF 1
+68 ;
+69 DO FINISH^OCXOLOG(OCXOLOG)
+70 ;
+71 KILL ^TMP($JOB,"OCXLDATA")
+72 ;
+73 QUIT
+74 ;
LOADATA(OCXSEG,OCXSD) ; Get '|' piece #OCXPC of OCXSD Segment Data array.
+1 ;
+2 NEW OCXTEXT,OCXPCNT,OCXD0,OCXD1
+3 ;
+4 if '$LENGTH(OCXSEG)
QUIT
+5 SET OCXPCNT=0
SET OCXD0=""
FOR
SET OCXD0=$ORDER(@OCXSD@(OCXD0))
if '$LENGTH(OCXD0)
QUIT
Begin DoDot:1
+6 SET OCXTEXT=$GET(@OCXSD@(OCXD0))
+7 FOR OCXD1=1:1:$LENGTH(OCXTEXT)
Begin DoDot:2
+8 IF ($EXTRACT(OCXTEXT,OCXD1)="|")
SET OCXPCNT=OCXPCNT+1
QUIT
+9 IF ($LENGTH($GET(OCXODATA(OCXSEG,OCXPCNT)))<241)
SET OCXODATA(OCXSEG,OCXPCNT)=$GET(OCXODATA(OCXSEG,OCXPCNT))_$EXTRACT(OCXTEXT,OCXD1)
End DoDot:2
End DoDot:1
+10 ;
+11 QUIT
+12 ;
RTEST() ; Does ^OCXOZ01 exist ?? Is it currently being compiled ??
+1 NEW DATE,TMOUT
+2 if '$LENGTH($TEXT(^OCXOZ01))
QUIT 1
+3 IF '($PIECE($GET(^OCXD(861,1,0)),U,1)="SITE PREFERENCES")
KILL ^OCXD(861,1)
SET ^OCXD(861,1,0)="SITE PREFERENCES"
+4 SET DATE=$PIECE($GET(^OCXD(861,1,0)),U,3)
+5 IF DATE
IF ((+DATE)=(+$HOROLOG))
IF (((+$PIECE($HOROLOG,",",2))-(+$PIECE(DATE,",",2)))<1800)
QUIT 1
+6 QUIT 0
+7 ;
LOG(OCXARY) ;
+1 ; Log Data Messages
+2 ;
+3 IF $GET(OCXTRACE)
IF $$CDATA^OCXOZ01
if $GET(OCXTRACE)
WRITE !," Raw Input Data: ",!
DO ZW(OCXARY)
QUIT 0
+4 if '$LENGTH($TEXT(LOG^OCXOZ01))
QUIT 0
if '$$LOG^OCXOZ01
QUIT 0
+5 NEW OCXDFN,OCXNL
+6 IF '$ORDER(@OCXARY@(0))
SET OCXARY="OCXNL"
SET OCXNL(1)="Null HL7 Data Array Found"
+7 SET OCXDFN=$$GETDFN(OCXARY)
+8 QUIT $$NEW^OCXOLOG(OCXARY,"HL7",+$GET(DUZ),+OCXDFN)
+9 ;
ARYSIZE(ARY) ; Get array size (Local or Global)
+1 ;
+2 NEW ARY1,SIZE
+3 ;
+4 SET SIZE=0
+5 ;
+6 IF '(ARY["^")
FOR
SET ARY=$QUERY(@ARY)
if '$LENGTH(ARY)
QUIT
SET SIZE=SIZE+$LENGTH(@ARY)
+7 ;
+8 IF (ARY["^")
Begin DoDot:1
+9 SET ARY=$NAME(@ARY)
SET ARY1=ARY
+10 if ($EXTRACT(ARY,$LENGTH(ARY))=")")
SET ARY=$EXTRACT(ARY,1,$LENGTH(ARY)-1)_","
+11 FOR
SET ARY1=$QUERY(@ARY1)
if '$LENGTH(ARY1)
QUIT
if '(ARY1[ARY)
QUIT
SET SIZE=SIZE+$LENGTH(@ARY1)
End DoDot:1
+12 ;
+13 QUIT SIZE
+14 ;
ZW(ARY) ; ZWrite an array (Local or Global)
+1 ;
+2 NEW ARY1
+3 ;
+4 IF '(ARY["^")
Begin DoDot:1
+5 FOR
SET ARY=$QUERY(@ARY)
if '$LENGTH(ARY)
QUIT
WRITE !,ARY," = ",@ARY
End DoDot:1
QUIT
+6 ;
+7 IF (ARY["^")
Begin DoDot:1
+8 SET ARY=$NAME(@ARY)
SET ARY1=ARY
+9 if ($EXTRACT(ARY,$LENGTH(ARY))=")")
SET ARY=$EXTRACT(ARY,1,$LENGTH(ARY)-1)_","
+10 FOR
SET ARY1=$QUERY(@ARY1)
if '$LENGTH(ARY1)
QUIT
if '(ARY1[ARY)
QUIT
WRITE !,ARY1," = ",@ARY1
End DoDot:1
QUIT
+11 ;
+12 QUIT
+13 ;
ERROR QUIT
+1 ;
+2 ; **** Old Labels to insure backwards compatibility ****
+3 ;
+4 ;
GETDFN(ARRAY) ; Returns the patient IEN from file 2.
+1 ;
+2 NEW OCXNDX,OCXARY,OCXP1,OCXP2,OCXP3
+3 SET OCXARY=$SELECT($LENGTH($GET(ARRAY)):ARRAY,1:"ARRAY")
+4 SET OCXNDX=0
FOR
SET OCXNDX=$ORDER(@OCXARY@(OCXNDX))
if 'OCXNDX
QUIT
IF $PIECE($GET(@OCXARY@(OCXNDX)),"|",1)="PID"
QUIT
+5 if 'OCXNDX
QUIT 0
+6 ;
+7 SET OCXP1=$PIECE($GET(@OCXARY@(OCXNDX)),"|",4)
+8 SET OCXP2=$PIECE($GET(@OCXARY@(OCXNDX)),"|",5)
+9 SET OCXP3=$PIECE($GET(@OCXARY@(OCXNDX)),"|",6)
+10 ;
+11 if (OCXP2["DPT(")
QUIT +OCXP2
+12 ;
+13 IF $LENGTH(OCXP3)
IF ($PIECE($GET(^DPT(+OCXP1,0)),U,1)=OCXP3)
QUIT +OCXP1
+14 ;
+15 QUIT 0
+16 ;
+17 ; Old line label area.
+18 ;
PROC(OCXMSG,OUTMSG) ;
+1 DO SILENT(.OCXMSG,.OUTMSG)
+2 QUIT
+3 ;
EN(OCXMSG) ;
+1 DO VERBOSE(.OCXMSG)
+2 QUIT
+3 ;
