OCXSEND1 ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Get List of Objects to Transport) ;2/01/01 09:06
;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,105**;Dec 17,1997
;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
;
S ;
;
N OCXFILE,OCXD0
;
F S OCXFILE=$$GETFILE Q:'OCXFILE I (OCXFILE>1) F D ADDON Q:'$$GETREC(OCXFILE)
;
Q
;
GETREC(OCXFILE) ;
;
N OCXDIAG,OCXD0,OCXD1,OCXX,OCXADD,OCXSCR
S OCXDIAG="Select an"_$S($O(^TMP("OCXSEND",$J,"LIST",+OCXFILE,0)):"other",1:"")
S OCXDIAG=OCXDIAG_" "_$P(OCXFILE,U,2)_": "
S OCXID="I $D(^TMP(""OCXSEND"",$J,"_(+OCXFILE)_",""B"",$P(^(0),U,1))) W "" ***** Already selected for transport. *****"""
S:(+OCXFILE=860.8) OCXID="W:$L($P(^(0),U,2)) ?35,""$$"",$P(^(0),U,2),""() "" "_OCXID
S OCXSCR=""
W !!,OCXDIAG R OCXX:DTIME E W " <timeout>",$C(7) Q 0
Q:(OCXX[U) 0 Q:'$L(OCXX) 0
S OCXADD=1 I ($E(OCXX,1)="-") S OCXX=$E(OCXX,2,$L(OCXX)),OCXADD=0
;
I (OCXX="?") D
.I '$O(^TMP("OCXSEND",$J,"LIST",+OCXFILE,0)) W !!,"None Selected for transport"
.E W !!,"Already selected for transport:" D
..S OCXD0="" F S OCXD0=$O(^TMP("OCXSEND",$J,"LIST",+OCXFILE,"B",OCXD0)) Q:'$L(OCXD0) D
...W !,?5,OCXD0
...I (+OCXFILE=860.8) D
....S OCXD1=$O(^TMP("OCXSEND",$J,"LIST",+OCXFILE,"B",OCXD0,0)) Q:'OCXD1
....W:$L($P($G(^OCXS(860.8,+OCXD1,0)),U,2)) " $$",$P($G(^OCXS(860.8,+OCXD1,0)),U,2),"()"
.W !!,"Press <Enter> to continue..." R OCXD0:DTIME E Q
.S OCXSCR="I '$D(^TMP(""OCXSEND"",$J,"_(+OCXFILE)_",""B"",$P(^(0),U,1)))"
.S OCXX="??"
;
I (OCXX["*") D Q 1
.N OCXPAT,OCXCNT,OCXLEN,OCXNAME
.S OCXPAT=""
.F Q:(OCXX'["**") S OCXX=$P(OCXX,"**",1)_"*"_$P(OCXX,"**",2,999)
.S OCXLEN=$L(OCXX,"*")
.F OCXCNT=1:1:OCXLEN D
..S:$L($P(OCXX,"*",1)) OCXPAT=OCXPAT_"1"""_$P(OCXX,"*",1)_""""
..S:(OCXX["*") OCXPAT=OCXPAT_".E"
..S OCXX=$P(OCXX,"*",2,999)
.S OCXD0=0 F S OCXD0=$O(^OCXS(+OCXFILE,OCXD0)) Q:'OCXD0 D
..S OCXNAME=$P($G(^OCXS(+OCXFILE,OCXD0,0)),U,1)
..X "I OCXNAME?"_OCXPAT E Q
..I OCXADD D ADDREC(+OCXFILE,OCXD0)
..I 'OCXADD D DELREC(+OCXFILE,OCXD0)
;
S OCXD0=$$DIC(+OCXFILE,"EMQ",OCXDIAG,OCXX,OCXSCR,OCXID)
I OCXD0 H 1 D
.I OCXADD D ADDREC(OCXFILE,OCXD0)
.I 'OCXADD D DELREC(OCXFILE,OCXD0)
;
Q 1
;
ADDON ;
;
I $O(^TMP("OCXSEND",$J,"LIST",0)) D
.S OCXD0=0 F S OCXD0=$O(^OCXS(860.9,OCXD0)) Q:'OCXD0 D
..I $D(^OCXS(860.9,OCXD0,0)) D CHECK^OCXSENDB(860.9,OCXD0)
.D CHECK^OCXSENDB(860.8,"FILE")
.D CHECK^OCXSENDB(860.8,"GETDATA")
.D CHECK^OCXSENDB(860.8,"DT2INT")
.D CHECK^OCXSENDB(860.8,"INT2DT")
.D CHECK^OCXSENDB(860.8,"LIST")
.D CHECK^OCXSENDB(860.8,"CLIST")
.D CHECK^OCXSENDB(860.8,"EQTERM")
.D CHECK^OCXSENDB(860.8,"NEWRULE")
.D CHECK^OCXSENDB(860.8,"POINTER")
.D CHECK^OCXSENDB(860.4,"PATIENT IEN")
;
Q
;
ADDREC(FILE,REC) ;
;
N LLAB
S FILE=+FILE,REC=+REC
Q:'$D(^OCXS(FILE,REC))
Q:$D(^TMP("OCXSEND",$J,"LIST",FILE,REC))
S ^TMP("OCXSEND",$J,"LIST",FILE,REC)=$P($G(^OCXS(FILE,REC,0)),U,1)
S ^TMP("OCXSEND",$J,"LIST",FILE,"B",$P($G(^OCXS(FILE,REC,0)),U,1),REC)=""
W !,$P(^OCXS(FILE,0),U,1)," --> ",$P($G(^OCXS(FILE,REC,0)),U,1)," added to list."
;
S LLAB=$TR(FILE,".","")_"^OCXSENDB"
X "I $L($T("_LLAB_"))" E Q
D @LLAB
Q
;
DELREC(FILE,REC) ;
;
N OCXNAME
S OCXNAME=$G(^TMP("OCXSEND",$J,"LIST",+FILE,+REC)) Q:'$L(OCXNAME)
K ^TMP("OCXSEND",$J,"LIST",+FILE,+REC)
K ^TMP("OCXSEND",$J,"LIST",+FILE,"B",OCXNAME,+REC)
W !,OCXNAME," removed from list."
Q
;
GETFILE() ;
;
N OCXDIAG,OCXD0,OCXX,OCXADD
S OCXDIAG="Select a"_$S($O(^TMP("OCXSEND",$J,"LIST",0)):"nother",1:"")_" File: "
S OCXSCR="I $D(^OCXS(+$P(^(0),U,2),0)),$O(^OCXS(+$P(^(0),U,2),0))"
S OCXID="N OCXCNT S OCXCNT=$$CNT^OCXSEND1(+$P(^(0),U,2)) I OCXCNT W ?50,$J(OCXCNT,5),"" selected for transport."""
W !!,OCXDIAG R OCXX:DTIME E W " <timeout>",$C(7) Q 0
Q:(OCXX[U) 0 Q:'$L(OCXX) 0
;
I (OCXX="?") S OCXX="??"
;
S OCXD0=$$DIC(1,"EMQ",OCXDIAG,OCXX,OCXSCR,OCXID)
;
Q:OCXD0 OCXD0 Q:$L(OCXX) 1 Q 0
;
CNT(OCXFILE) ;
;
N CNT,OCXD0
S OCXD0=0 F CNT=0:1 S OCXD0=$O(^TMP("OCXSEND",$J,"LIST",OCXFILE,OCXD0)) Q:'OCXD0
Q CNT
;
DIC(OCXDIC,OCXDIC0,OCXDICA,OCXX,OCXDICS,OCXW) ;
;
N DIC,X,Y
S DIC=$G(OCXDIC) Q:'$L(DIC) -1
S DIC(0)=$G(OCXDIC0) S:$L($G(OCXX)) X=OCXX
S:$L($G(OCXDICS)) DIC("S")=OCXDICS
S:$L($G(OCXDICA)) DIC("A")=OCXDICA
S:$L($G(OCXW)) DIC("W")=OCXW
D ^DIC Q:(Y<1) 0 Q Y
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOCXSEND1 4408 printed Apr 09, 2024@21:32:41 Page 2
OCXSEND1 ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Get List of Objects to Transport) ;2/01/01 09:06
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,105**;Dec 17,1997
+2 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
+3 ;
S ;
+1 ;
+2 NEW OCXFILE,OCXD0
+3 ;
+4 FOR
SET OCXFILE=$$GETFILE
if 'OCXFILE
QUIT
IF (OCXFILE>1)
FOR
DO ADDON
if '$$GETREC(OCXFILE)
QUIT
+5 ;
+6 QUIT
+7 ;
GETREC(OCXFILE) ;
+1 ;
+2 NEW OCXDIAG,OCXD0,OCXD1,OCXX,OCXADD,OCXSCR
+3 SET OCXDIAG="Select an"_$SELECT($ORDER(^TMP("OCXSEND",$JOB,"LIST",+OCXFILE,0)):"other",1:"")
+4 SET OCXDIAG=OCXDIAG_" "_$PIECE(OCXFILE,U,2)_": "
+5 SET OCXID="I $D(^TMP(""OCXSEND"",$J,"_(+OCXFILE)_",""B"",$P(^(0),U,1))) W "" ***** Already selected for transport. *****"""
+6 if (+OCXFILE=860.8)
SET OCXID="W:$L($P(^(0),U,2)) ?35,""$$"",$P(^(0),U,2),""() "" "_OCXID
+7 SET OCXSCR=""
+8 WRITE !!,OCXDIAG
READ OCXX:DTIME
IF '$TEST
WRITE " <timeout>",$CHAR(7)
QUIT 0
+9 if (OCXX[U)
QUIT 0
if '$LENGTH(OCXX)
QUIT 0
+10 SET OCXADD=1
IF ($EXTRACT(OCXX,1)="-")
SET OCXX=$EXTRACT(OCXX,2,$LENGTH(OCXX))
SET OCXADD=0
+11 ;
+12 IF (OCXX="?")
Begin DoDot:1
+13 IF '$ORDER(^TMP("OCXSEND",$JOB,"LIST",+OCXFILE,0))
WRITE !!,"None Selected for transport"
+14 IF '$TEST
WRITE !!,"Already selected for transport:"
Begin DoDot:2
+15 SET OCXD0=""
FOR
SET OCXD0=$ORDER(^TMP("OCXSEND",$JOB,"LIST",+OCXFILE,"B",OCXD0))
if '$LENGTH(OCXD0)
QUIT
Begin DoDot:3
+16 WRITE !,?5,OCXD0
+17 IF (+OCXFILE=860.8)
Begin DoDot:4
+18 SET OCXD1=$ORDER(^TMP("OCXSEND",$JOB,"LIST",+OCXFILE,"B",OCXD0,0))
if 'OCXD1
QUIT
+19 if $LENGTH($PIECE($GET(^OCXS(860.8,+OCXD1,0)),U,2))
WRITE " $$",$PIECE($GET(^OCXS(860.8,+OCXD1,0)),U,2),"()"
End DoDot:4
End DoDot:3
End DoDot:2
+20 WRITE !!,"Press <Enter> to continue..."
READ OCXD0:DTIME
IF '$TEST
QUIT
+21 SET OCXSCR="I '$D(^TMP(""OCXSEND"",$J,"_(+OCXFILE)_",""B"",$P(^(0),U,1)))"
+22 SET OCXX="??"
End DoDot:1
+23 ;
+24 IF (OCXX["*")
Begin DoDot:1
+25 NEW OCXPAT,OCXCNT,OCXLEN,OCXNAME
+26 SET OCXPAT=""
+27 FOR
if (OCXX'["**")
QUIT
SET OCXX=$PIECE(OCXX,"**",1)_"*"_$PIECE(OCXX,"**",2,999)
+28 SET OCXLEN=$LENGTH(OCXX,"*")
+29 FOR OCXCNT=1:1:OCXLEN
Begin DoDot:2
+30 if $LENGTH($PIECE(OCXX,"*",1))
SET OCXPAT=OCXPAT_"1"""_$PIECE(OCXX,"*",1)_""""
+31 if (OCXX["*")
SET OCXPAT=OCXPAT_".E"
+32 SET OCXX=$PIECE(OCXX,"*",2,999)
End DoDot:2
+33 SET OCXD0=0
FOR
SET OCXD0=$ORDER(^OCXS(+OCXFILE,OCXD0))
if 'OCXD0
QUIT
Begin DoDot:2
+34 SET OCXNAME=$PIECE($GET(^OCXS(+OCXFILE,OCXD0,0)),U,1)
+35 XECUTE "I OCXNAME?"_OCXPAT
IF '$TEST
QUIT
+36 IF OCXADD
DO ADDREC(+OCXFILE,OCXD0)
+37 IF 'OCXADD
DO DELREC(+OCXFILE,OCXD0)
End DoDot:2
End DoDot:1
QUIT 1
+38 ;
+39 SET OCXD0=$$DIC(+OCXFILE,"EMQ",OCXDIAG,OCXX,OCXSCR,OCXID)
+40 IF OCXD0
HANG 1
Begin DoDot:1
+41 IF OCXADD
DO ADDREC(OCXFILE,OCXD0)
+42 IF 'OCXADD
DO DELREC(OCXFILE,OCXD0)
End DoDot:1
+43 ;
+44 QUIT 1
+45 ;
ADDON ;
+1 ;
+2 IF $ORDER(^TMP("OCXSEND",$JOB,"LIST",0))
Begin DoDot:1
+3 SET OCXD0=0
FOR
SET OCXD0=$ORDER(^OCXS(860.9,OCXD0))
if 'OCXD0
QUIT
Begin DoDot:2
+4 IF $DATA(^OCXS(860.9,OCXD0,0))
DO CHECK^OCXSENDB(860.9,OCXD0)
End DoDot:2
+5 DO CHECK^OCXSENDB(860.8,"FILE")
+6 DO CHECK^OCXSENDB(860.8,"GETDATA")
+7 DO CHECK^OCXSENDB(860.8,"DT2INT")
+8 DO CHECK^OCXSENDB(860.8,"INT2DT")
+9 DO CHECK^OCXSENDB(860.8,"LIST")
+10 DO CHECK^OCXSENDB(860.8,"CLIST")
+11 DO CHECK^OCXSENDB(860.8,"EQTERM")
+12 DO CHECK^OCXSENDB(860.8,"NEWRULE")
+13 DO CHECK^OCXSENDB(860.8,"POINTER")
+14 DO CHECK^OCXSENDB(860.4,"PATIENT IEN")
End DoDot:1
+15 ;
+16 QUIT
+17 ;
ADDREC(FILE,REC) ;
+1 ;
+2 NEW LLAB
+3 SET FILE=+FILE
SET REC=+REC
+4 if '$DATA(^OCXS(FILE,REC))
QUIT
+5 if $DATA(^TMP("OCXSEND",$JOB,"LIST",FILE,REC))
QUIT
+6 SET ^TMP("OCXSEND",$JOB,"LIST",FILE,REC)=$PIECE($GET(^OCXS(FILE,REC,0)),U,1)
+7 SET ^TMP("OCXSEND",$JOB,"LIST",FILE,"B",$PIECE($GET(^OCXS(FILE,REC,0)),U,1),REC)=""
+8 WRITE !,$PIECE(^OCXS(FILE,0),U,1)," --> ",$PIECE($GET(^OCXS(FILE,REC,0)),U,1)," added to list."
+9 ;
+10 SET LLAB=$TRANSLATE(FILE,".","")_"^OCXSENDB"
+11 XECUTE "I $L($T("_LLAB_"))"
IF '$TEST
QUIT
+12 DO @LLAB
+13 QUIT
+14 ;
DELREC(FILE,REC) ;
+1 ;
+2 NEW OCXNAME
+3 SET OCXNAME=$GET(^TMP("OCXSEND",$JOB,"LIST",+FILE,+REC))
if '$LENGTH(OCXNAME)
QUIT
+4 KILL ^TMP("OCXSEND",$JOB,"LIST",+FILE,+REC)
+5 KILL ^TMP("OCXSEND",$JOB,"LIST",+FILE,"B",OCXNAME,+REC)
+6 WRITE !,OCXNAME," removed from list."
+7 QUIT
+8 ;
GETFILE() ;
+1 ;
+2 NEW OCXDIAG,OCXD0,OCXX,OCXADD
+3 SET OCXDIAG="Select a"_$SELECT($ORDER(^TMP("OCXSEND",$JOB,"LIST",0)):"nother",1:"")_" File: "
+4 SET OCXSCR="I $D(^OCXS(+$P(^(0),U,2),0)),$O(^OCXS(+$P(^(0),U,2),0))"
+5 SET OCXID="N OCXCNT S OCXCNT=$$CNT^OCXSEND1(+$P(^(0),U,2)) I OCXCNT W ?50,$J(OCXCNT,5),"" selected for transport."""
+6 WRITE !!,OCXDIAG
READ OCXX:DTIME
IF '$TEST
WRITE " <timeout>",$CHAR(7)
QUIT 0
+7 if (OCXX[U)
QUIT 0
if '$LENGTH(OCXX)
QUIT 0
+8 ;
+9 IF (OCXX="?")
SET OCXX="??"
+10 ;
+11 SET OCXD0=$$DIC(1,"EMQ",OCXDIAG,OCXX,OCXSCR,OCXID)
+12 ;
+13 if OCXD0
QUIT OCXD0
if $LENGTH(OCXX)
QUIT 1
QUIT 0
+14 ;
CNT(OCXFILE) ;
+1 ;
+2 NEW CNT,OCXD0
+3 SET OCXD0=0
FOR CNT=0:1
SET OCXD0=$ORDER(^TMP("OCXSEND",$JOB,"LIST",OCXFILE,OCXD0))
if 'OCXD0
QUIT
+4 QUIT CNT
+5 ;
DIC(OCXDIC,OCXDIC0,OCXDICA,OCXX,OCXDICS,OCXW) ;
+1 ;
+2 NEW DIC,X,Y
+3 SET DIC=$GET(OCXDIC)
if '$LENGTH(DIC)
QUIT -1
+4 SET DIC(0)=$GET(OCXDIC0)
if $LENGTH($GET(OCXX))
SET X=OCXX
+5 if $LENGTH($GET(OCXDICS))
SET DIC("S")=OCXDICS
+6 if $LENGTH($GET(OCXDICA))
SET DIC("A")=OCXDICA
+7 if $LENGTH($GET(OCXW))
SET DIC("W")=OCXW
+8 DO ^DIC
if (Y<1)
QUIT 0
QUIT Y
+9 ;
