ORY423ES ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE (Delete after Install of OR*3*423) ;JUN 29,2016 at 06:15
;;3.0;ORDER ENTRY/RESULTS REPORTING;**423**;Dec 17,1997;Build 19
;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
;
S ;
;
N OCXDIER,QUIT,LINE,TEXT,REMOTE,LOCAL,D0,OPCODE,REF,OCXFLAG S QUIT=0
N OCXAUTO,OCZSCR
;
D DOT
I $L($T(VERSION^OCXOCMP)),($$VERSION^OCXOCMP="ORDER CHECK EXPERT version 1.01 released OCT 29,1998"),1
E D Q
.W !
.W !,"Rule Transport aborted, version mismatch."
.W !,"Current Local version: ",$$VERSION^OCXOCMP
.W !," Rule Transport Version: ORDER CHECK EXPERT version 1.01 released OCT 29,1998"
I '$D(DTIME) W !!,"DTIME not defined !!",!! Q
W !!,"Order Check Expert System Rule Transporter"
W !," Created: JUN 29,2016 at 06:15 at CPRS30.FO-SLC.DOMAIN.EXT"
W !," Current Date: ",$$NOW^ORY4230," at ",$$NETNAME^OCXSEND,!!
S LASTFILE=0 K ^TMP("OCXRULE",$J)
S ^TMP("OCXRULE",$J)=($P($H,",",2)+($H*86400)+(1*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG"
S OCXFLAG="O"
;
RUN ;
;
W !,"Loading Data " D ^ORY42301
;
S LINE=0 F S LINE=$O(^TMP("OCXRULE",$J,LINE)) Q:'LINE D Q:QUIT
.D:'(LINE#50) STATUS^OCXOPOST(LINE,$O(^TMP("OCXRULE",$J," "),-1))
.S TEXT=$G(^TMP("OCXRULE",$J,LINE)) I $L(TEXT) D Q:QUIT
..S TEXT=$P(TEXT,";",2,999),OPCODE=$P(TEXT,U,1),TEXT=$P(TEXT,U,2,999)
..;
..I OPCODE="KEY" D DOT S LOCAL="",D0=$$GETFILE^ORY4230(+$P(TEXT,U,1),$P(TEXT,U,2),.LOCAL) S QUIT=(D0=(-10)) Q
..I OPCODE="R" S REF="REMOTE("_$P(TEXT,":",1)_":"_D0_$P(TEXT,":",2,99)_")" Q
..I OPCODE="D",$D(REF) S @REF=$P(TEXT,U,1,999) K REF Q
..;
..I OPCODE="EOR" S QUIT=$$COMPARE^ORY4231(.LOCAL,.REMOTE) K LOCAL,REMOTE Q
..I OPCODE="EOF" K LOCAL,REMOTE Q
..I OPCODE="SOF" W !," Installing '",TEXT,"' records... " Q
..I OPCODE="ROOT" D Q
...N FILE,DATA
...S FILE=U_$P(TEXT,U,1),DATA=$P(TEXT,U,2,3)
...I ($P($G(@FILE),U,1,2)=DATA) Q
...S $P(@FILE,U,1,2)=DATA
...W !," Restoring file #",(+$P(DATA,U,2))," zero node"
..;
..W !,"Unknown OpCode: ",OPCODE," in: ",TEXT S QUIT=$$PAUSE^ORY4230 W !
;
K ^TMP("OCXRULE",$J)
;
I $D(^OCXS) D
.N FILE,DO,PD0,CNT
.S FILE=0 F S FILE=$O(^OCXS(FILE)) Q:'FILE D
..S D0=0 F CNT=0:1 S PD0=D0,D0=$O(^OCXS(FILE,D0)) Q:'D0
..S $P(^OCXS(FILE,0),U,3,4)=CNT_U_PD0
;
I $G(OCXDIER) D
.W !!!!!!!
.W !,?5,"******************** Warning ******************** "
.W !,?7,+$G(OCXDIER)," data filing error",$S(($G(OCXDIER)=1):"",1:"s"),"."
.W !,?7,"Some expert system rules may be incomplete."
.W !,?5,"******************** Warning ******************** "
I '$G(OCXDIER) W !!,?5," No data filing errors."
W !!,"Transport Finished..."
;
D
.N OCXOETIM
.D BMES^XPDUTL("---Creating Order Check Routines-----------------------------------")
.D AUTO^OCXOCMP
;
Q
;
DOT Q:$G(OCXAUTO) W:($X>70) ! W " ." Q
;
READ(OCXZ0,OCXZA,OCXZB,OCXZL) ;
N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT
Q:'$L($G(OCXZ0)) U
S DIR(0)=OCXZ0
S:$L($G(OCXZA)) DIR("A")=OCXZA
S:$L($G(OCXZB)) DIR("B")=OCXZB
F OCXLINE=1:1:($G(OCXZL)-1) W !
D ^DIR
I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U
Q Y
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORY423ES 3174 printed Dec 13, 2024@02:42:06 Page 2
ORY423ES ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE (Delete after Install of OR*3*423) ;JUN 29,2016 at 06:15
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**423**;Dec 17,1997;Build 19
+2 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
+3 ;
S ;
+1 ;
+2 NEW OCXDIER,QUIT,LINE,TEXT,REMOTE,LOCAL,D0,OPCODE,REF,OCXFLAG
SET QUIT=0
+3 NEW OCXAUTO,OCZSCR
+4 ;
+5 DO DOT
+6 IF $LENGTH($TEXT(VERSION^OCXOCMP))
IF ($$VERSION^OCXOCMP="ORDER CHECK EXPERT version 1.01 released OCT 29,1998")
IF 1
+7 IF '$TEST
Begin DoDot:1
+8 WRITE !
+9 WRITE !,"Rule Transport aborted, version mismatch."
+10 WRITE !,"Current Local version: ",$$VERSION^OCXOCMP
+11 WRITE !," Rule Transport Version: ORDER CHECK EXPERT version 1.01 released OCT 29,1998"
End DoDot:1
QUIT
+12 IF '$DATA(DTIME)
WRITE !!,"DTIME not defined !!",!!
QUIT
+13 WRITE !!,"Order Check Expert System Rule Transporter"
+14 WRITE !," Created: JUN 29,2016 at 06:15 at CPRS30.FO-SLC.DOMAIN.EXT"
+15 WRITE !," Current Date: ",$$NOW^ORY4230," at ",$$NETNAME^OCXSEND,!!
+16 SET LASTFILE=0
KILL ^TMP("OCXRULE",$JOB)
+17 SET ^TMP("OCXRULE",$JOB)=($PIECE($HOROLOG,",",2)+($HOROLOG*86400)+(1*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG"
+18 SET OCXFLAG="O"
+19 ;
RUN ;
+1 ;
+2 WRITE !,"Loading Data "
DO ^ORY42301
+3 ;
+4 SET LINE=0
FOR
SET LINE=$ORDER(^TMP("OCXRULE",$JOB,LINE))
if 'LINE
QUIT
Begin DoDot:1
+5 if '(LINE#50)
DO STATUS^OCXOPOST(LINE,$ORDER(^TMP("OCXRULE",$JOB," "),-1))
+6 SET TEXT=$GET(^TMP("OCXRULE",$JOB,LINE))
IF $LENGTH(TEXT)
Begin DoDot:2
+7 SET TEXT=$PIECE(TEXT,";",2,999)
SET OPCODE=$PIECE(TEXT,U,1)
SET TEXT=$PIECE(TEXT,U,2,999)
+8 ;
+9 IF OPCODE="KEY"
DO DOT
SET LOCAL=""
SET D0=$$GETFILE^ORY4230(+$PIECE(TEXT,U,1),$PIECE(TEXT,U,2),.LOCAL)
SET QUIT=(D0=(-10))
QUIT
+10 IF OPCODE="R"
SET REF="REMOTE("_$PIECE(TEXT,":",1)_":"_D0_$PIECE(TEXT,":",2,99)_")"
QUIT
+11 IF OPCODE="D"
IF $DATA(REF)
SET @REF=$PIECE(TEXT,U,1,999)
KILL REF
QUIT
+12 ;
+13 IF OPCODE="EOR"
SET QUIT=$$COMPARE^ORY4231(.LOCAL,.REMOTE)
KILL LOCAL,REMOTE
QUIT
+14 IF OPCODE="EOF"
KILL LOCAL,REMOTE
QUIT
+15 IF OPCODE="SOF"
WRITE !," Installing '",TEXT,"' records... "
QUIT
+16 IF OPCODE="ROOT"
Begin DoDot:3
+17 NEW FILE,DATA
+18 SET FILE=U_$PIECE(TEXT,U,1)
SET DATA=$PIECE(TEXT,U,2,3)
+19 IF ($PIECE($GET(@FILE),U,1,2)=DATA)
QUIT
+20 SET $PIECE(@FILE,U,1,2)=DATA
+21 WRITE !," Restoring file #",(+$PIECE(DATA,U,2))," zero node"
End DoDot:3
QUIT
+22 ;
+23 WRITE !,"Unknown OpCode: ",OPCODE," in: ",TEXT
SET QUIT=$$PAUSE^ORY4230
WRITE !
End DoDot:2
if QUIT
QUIT
End DoDot:1
if QUIT
QUIT
+24 ;
+25 KILL ^TMP("OCXRULE",$JOB)
+26 ;
+27 IF $DATA(^OCXS)
Begin DoDot:1
+28 NEW FILE,DO,PD0,CNT
+29 SET FILE=0
FOR
SET FILE=$ORDER(^OCXS(FILE))
if 'FILE
QUIT
Begin DoDot:2
+30 SET D0=0
FOR CNT=0:1
SET PD0=D0
SET D0=$ORDER(^OCXS(FILE,D0))
if 'D0
QUIT
+31 SET $PIECE(^OCXS(FILE,0),U,3,4)=CNT_U_PD0
End DoDot:2
End DoDot:1
+32 ;
+33 IF $GET(OCXDIER)
Begin DoDot:1
+34 WRITE !!!!!!!
+35 WRITE !,?5,"******************** Warning ******************** "
+36 WRITE !,?7,+$GET(OCXDIER)," data filing error",$SELECT(($GET(OCXDIER)=1):"",1:"s"),"."
+37 WRITE !,?7,"Some expert system rules may be incomplete."
+38 WRITE !,?5,"******************** Warning ******************** "
End DoDot:1
+39 IF '$GET(OCXDIER)
WRITE !!,?5," No data filing errors."
+40 WRITE !!,"Transport Finished..."
+41 ;
+42 Begin DoDot:1
+43 NEW OCXOETIM
+44 DO BMES^XPDUTL("---Creating Order Check Routines-----------------------------------")
+45 DO AUTO^OCXOCMP
End DoDot:1
+46 ;
+47 QUIT
+48 ;
DOT if $GET(OCXAUTO)
QUIT
if ($X>70)
WRITE !
WRITE " ."
QUIT
+1 ;
READ(OCXZ0,OCXZA,OCXZB,OCXZL) ;
+1 NEW OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT
+2 if '$LENGTH($GET(OCXZ0))
QUIT U
+3 SET DIR(0)=OCXZ0
+4 if $LENGTH($GET(OCXZA))
SET DIR("A")=OCXZA
+5 if $LENGTH($GET(OCXZB))
SET DIR("B")=OCXZB
+6 FOR OCXLINE=1:1:($GET(OCXZL)-1)
WRITE !
+7 DO ^DIR
+8 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
QUIT U
+9 QUIT Y
+10 ;
