- 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 Jan 18, 2025@03:43:14 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 ;