- ORY2340 ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE (Delete after Install of OR*3*234) ;MAY 13,2005 at 09:31
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**234**;Dec 17,1997
- ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
- ;
- S ;
- ;
- Q
- ;
- WARN(RTN,MSG,LINES) ;
- ;
- Q:$G(OCXAUTO)
- ;
- N DASH,LINE,NLINE,PLINE
- ;
- S DASH="",$P(DASH,"-",(55-$L(MSG)-2))="-"
- W !!,"--------------",MSG,DASH
- ;
- W !,RTN,?10,"[DEVCUR.FO-SLC.DOMAIN.EXT] -> [",$$NETNAME^OCXSEND,"] Line"
- ;
- I $O(LINES($O(LINES(0)))) W "s: "
- E W ": "
- ;
- S LINE=0 F S LINE=$O(LINES(LINE)) Q:'LINE D
- .W:($X>60) !,?40
- .S NLINE=LINE F S PLINE=NLINE,NLINE=$O(LINES(NLINE)) Q:(NLINE-PLINE-1)
- .I (PLINE=LINE) W " ",LINE
- .E W " ",LINE,"-",PLINE S LINE=PLINE
- ;
- W ! Q
- ;
- TEXT(RTN,LINE) ;
- ;
- N TEXT X "S TEXT=$T(+"_(+LINE)_"^"_RTN_")" Q TEXT
- ;
- ;
- W !," Created: MAY 13,2005 at 09:31 at DEVCUR.FO-SLC.DOMAIN.EXT"
- W !," Current Date: ",$$NOW," 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"
- Q
- ;
- GETFILE(FILE,RECNAME,ARRAY) ;
- ;
- N CHECK,GLNEXT,GLREF,LINES,REC,DD,FLD
- S REC=$$LOOKUP(FILE,RECNAME)
- I 'REC W !!,$$FILENAME^OCXSENDD(FILE),": ",RECNAME Q 0
- I (REC=-1) W !!,$$FILENAME^OCXSENDD(FILE),": ",RECNAME," duplicate local entries.",! Q 0
- I (REC=-2) W !!,$$FILENAME^OCXSENDD(FILE)," (",FILE,") local file not found." W ! Q:$$PAUSE -10 Q REC
- I (REC<0) W !!,$$FILENAME^OCXSENDD(FILE),": ",RECNAME," unknown lookup error." W ! Q:$$PAUSE -10 Q REC
- I (REC>0) D
- .S CHECK=0,LINES=0
- .D GETREC($$FILE^OCXSENDD(FILE,"GLOBAL NAME"),"ARRAY(",REC,.ARRAY)
- .S GLREF="ARRAY" F S GLREF=$Q(@GLREF) Q:'$L(GLREF) Q:'($E(GLREF,1,6)="ARRAY(") K:'$L(@GLREF) @GLREF
- ;
- Q REC
- ;
- LKUPARRY(DD,KEY,ARRAY) ;
- ;
- N D0 S D0=0 F S D0=$O(ARRAY(DD,D0)) Q:'D0 Q:($G(ARRAY(DD,D0,.01,"E"))=KEY)
- Q D0
- ;
- LOOKUP(FILE,KEY) ;
- I $O(^TMP("OCXRULE",$J,"B",FILE,KEY,0)) Q 0
- N RECNAM,REC,D0,CNT,SHORT S (REC,CNT)=0
- S GL=$$FILE^OCXSENDD(FILE,"GLOBAL NAME") Q:'$L(GL) -2 S GL=$E(GL,1,$L(GL)-1)_")"
- S SHORT=$E(KEY,1,30),RECNAM=SHORT D F S RECNAM=$O(@GL@("B",RECNAM)) Q:'$L(RECNAM) Q:'($E(RECNAM,1,$L(SHORT))=SHORT) D
- .S D0=0 F S D0=$O(@GL@("B",RECNAM,D0)) Q:'D0 I ($P($G(@GL@(D0,0)),U,1)=KEY) S CNT=CNT+1,REC=D0_U_RECNAME
- Q:(CNT>1) -1
- S:$L($P(REC,U,2)) ^TMP("OCXRULE",$J,"A",FILE,$P(REC,U,2))=""
- Q +REC
- ;
- GETREC(GL,PATH,D0,REM) ;
- ;
- Q:'($P($G(@(GL_"0)")),U,2))
- N S1,DATA,DD
- S DATA="" D DIQ(GL,D0,.DATA)
- S DD=$O(DATA(0)) Q:'DD
- ;
- I $L($$FILE^OCXSENDD(DD,"NAME")) S PATH=PATH_""""_DD_":"_D0_""""
- I '$L($$FILE^OCXSENDD(DD,"NAME")) S PATH=PATH_","""_DD_":"_D0_""""
- M @(PATH_")")=DATA(DD,D0)
- ;
- S S1="" F S S1=$O(@(GL_D0_","_$$SUB(S1)_")")) Q:'$L(S1) I ($D(@(GL_D0_","_$$SUB(S1)_")"))>3) D
- .N D1,GLREF S GLREF=GL_D0_","_$$SUB(S1)_","
- .S D1=0 F S D1=$O(@(GLREF_D1_")")) Q:'D1 D GETREC(GLREF,PATH,D1,.REM)
- ;
- Q
- ;
- SUB(X) Q:'(X=+X) """"_X_"""" Q X
- ;
- DIQ(DIC,DA,OCXARY) ;
- N DR,DIQ S DR=".01:99999",DIQ="OCXARY(",DIQ(0)="EN" D EN^DIQ1
- Q
- ;
- PAUSE() W " Press Enter " R X:DTIME W ! Q (X[U)
- ;
- NOW() N X,Y,%DT S X="N",%DT="T" D ^%DT S Y=$$DATE^OCXSENDD(Y) S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2) Q Y
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORY2340 3301 printed Jan 18, 2025@03:40:44 Page 2
- ORY2340 ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE (Delete after Install of OR*3*234) ;MAY 13,2005 at 09:31
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**234**;Dec 17,1997
- +2 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
- +3 ;
- S ;
- +1 ;
- +2 QUIT
- +3 ;
- WARN(RTN,MSG,LINES) ;
- +1 ;
- +2 if $GET(OCXAUTO)
- QUIT
- +3 ;
- +4 NEW DASH,LINE,NLINE,PLINE
- +5 ;
- +6 SET DASH=""
- SET $PIECE(DASH,"-",(55-$LENGTH(MSG)-2))="-"
- +7 WRITE !!,"--------------",MSG,DASH
- +8 ;
- +9 WRITE !,RTN,?10,"[DEVCUR.FO-SLC.DOMAIN.EXT] -> [",$$NETNAME^OCXSEND,"] Line"
- +10 ;
- +11 IF $ORDER(LINES($ORDER(LINES(0))))
- WRITE "s: "
- +12 IF '$TEST
- WRITE ": "
- +13 ;
- +14 SET LINE=0
- FOR
- SET LINE=$ORDER(LINES(LINE))
- if 'LINE
- QUIT
- Begin DoDot:1
- +15 if ($X>60)
- WRITE !,?40
- +16 SET NLINE=LINE
- FOR
- SET PLINE=NLINE
- SET NLINE=$ORDER(LINES(NLINE))
- if (NLINE-PLINE-1)
- QUIT
- +17 IF (PLINE=LINE)
- WRITE " ",LINE
- +18 IF '$TEST
- WRITE " ",LINE,"-",PLINE
- SET LINE=PLINE
- End DoDot:1
- +19 ;
- +20 WRITE !
- QUIT
- +21 ;
- TEXT(RTN,LINE) ;
- +1 ;
- +2 NEW TEXT
- XECUTE "S TEXT=$T(+"_(+LINE)_"^"_RTN_")"
- QUIT TEXT
- +3 ;
- +1 ;
- +2 WRITE !," Created: MAY 13,2005 at 09:31 at DEVCUR.FO-SLC.DOMAIN.EXT"
- +3 WRITE !," Current Date: ",$$NOW," at ",$$NETNAME^OCXSEND,!!
- +4 SET LASTFILE=0
- KILL ^TMP("OCXRULE",$JOB)
- +5 SET ^TMP("OCXRULE",$JOB)=($PIECE($HOROLOG,",",2)+($HOROLOG*86400)+(1*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG"
- +6 QUIT
- +7 ;
- GETFILE(FILE,RECNAME,ARRAY) ;
- +1 ;
- +2 NEW CHECK,GLNEXT,GLREF,LINES,REC,DD,FLD
- +3 SET REC=$$LOOKUP(FILE,RECNAME)
- +4 IF 'REC
- WRITE !!,$$FILENAME^OCXSENDD(FILE),": ",RECNAME
- QUIT 0
- +5 IF (REC=-1)
- WRITE !!,$$FILENAME^OCXSENDD(FILE),": ",RECNAME," duplicate local entries.",!
- QUIT 0
- +6 IF (REC=-2)
- WRITE !!,$$FILENAME^OCXSENDD(FILE)," (",FILE,") local file not found."
- WRITE !
- if $$PAUSE
- QUIT -10
- QUIT REC
- +7 IF (REC<0)
- WRITE !!,$$FILENAME^OCXSENDD(FILE),": ",RECNAME," unknown lookup error."
- WRITE !
- if $$PAUSE
- QUIT -10
- QUIT REC
- +8 IF (REC>0)
- Begin DoDot:1
- +9 SET CHECK=0
- SET LINES=0
- +10 DO GETREC($$FILE^OCXSENDD(FILE,"GLOBAL NAME"),"ARRAY(",REC,.ARRAY)
- +11 SET GLREF="ARRAY"
- FOR
- SET GLREF=$QUERY(@GLREF)
- if '$LENGTH(GLREF)
- QUIT
- if '($EXTRACT(GLREF,1,6)="ARRAY(")
- QUIT
- if '$LENGTH(@GLREF)
- KILL @GLREF
- End DoDot:1
- +12 ;
- +13 QUIT REC
- +14 ;
- LKUPARRY(DD,KEY,ARRAY) ;
- +1 ;
- +2 NEW D0
- SET D0=0
- FOR
- SET D0=$ORDER(ARRAY(DD,D0))
- if 'D0
- QUIT
- if ($GET(ARRAY(DD,D0,.01,"E"))=KEY)
- QUIT
- +3 QUIT D0
- +4 ;
- LOOKUP(FILE,KEY) ;
- +1 IF $ORDER(^TMP("OCXRULE",$JOB,"B",FILE,KEY,0))
- QUIT 0
- +2 NEW RECNAM,REC,D0,CNT,SHORT
- SET (REC,CNT)=0
- +3 SET GL=$$FILE^OCXSENDD(FILE,"GLOBAL NAME")
- if '$LENGTH(GL)
- QUIT -2
- SET GL=$EXTRACT(GL,1,$LENGTH(GL)-1)_")"
- +4 SET SHORT=$EXTRACT(KEY,1,30)
- SET RECNAM=SHORT
- Begin DoDot:1
- +5 SET D0=0
- FOR
- SET D0=$ORDER(@GL@("B",RECNAM,D0))
- if 'D0
- QUIT
- IF ($PIECE($GET(@GL@(D0,0)),U,1)=KEY)
- SET CNT=CNT+1
- SET REC=D0_U_RECNAME
- End DoDot:1
- FOR
- SET RECNAM=$ORDER(@GL@("B",RECNAM))
- if '$LENGTH(RECNAM)
- QUIT
- if '($EXTRACT(RECNAM,1,$LENGTH(SHORT))=SHORT)
- QUIT
- Begin DoDot:1
- End DoDot:1
- +6 if (CNT>1)
- QUIT -1
- +7 if $LENGTH($PIECE(REC,U,2))
- SET ^TMP("OCXRULE",$JOB,"A",FILE,$PIECE(REC,U,2))=""
- +8 QUIT +REC
- +9 ;
- GETREC(GL,PATH,D0,REM) ;
- +1 ;
- +2 if '($PIECE($GET(@(GL_"0)")),U,2))
- QUIT
- +3 NEW S1,DATA,DD
- +4 SET DATA=""
- DO DIQ(GL,D0,.DATA)
- +5 SET DD=$ORDER(DATA(0))
- if 'DD
- QUIT
- +6 ;
- +7 IF $LENGTH($$FILE^OCXSENDD(DD,"NAME"))
- SET PATH=PATH_""""_DD_":"_D0_""""
- +8 IF '$LENGTH($$FILE^OCXSENDD(DD,"NAME"))
- SET PATH=PATH_","""_DD_":"_D0_""""
- +9 MERGE @(PATH_")")=DATA(DD,D0)
- +10 ;
- +11 SET S1=""
- FOR
- SET S1=$ORDER(@(GL_D0_","_$$SUB(S1)_")"))
- if '$LENGTH(S1)
- QUIT
- IF ($DATA(@(GL_D0_","_$$SUB(S1)_")"))>3)
- Begin DoDot:1
- +12 NEW D1,GLREF
- SET GLREF=GL_D0_","_$$SUB(S1)_","
- +13 SET D1=0
- FOR
- SET D1=$ORDER(@(GLREF_D1_")"))
- if 'D1
- QUIT
- DO GETREC(GLREF,PATH,D1,.REM)
- End DoDot:1
- +14 ;
- +15 QUIT
- +16 ;
- SUB(X) if '(X=+X)
- QUIT """"_X_""""
- QUIT X
- +1 ;
- DIQ(DIC,DA,OCXARY) ;
- +1 NEW DR,DIQ
- SET DR=".01:99999"
- SET DIQ="OCXARY("
- SET DIQ(0)="EN"
- DO EN^DIQ1
- +2 QUIT
- +3 ;
- PAUSE() WRITE " Press Enter "
- READ X:DTIME
- WRITE !
- QUIT (X[U)
- +1 ;
- NOW() NEW X,Y,%DT
- SET X="N"
- SET %DT="T"
- DO ^%DT
- SET Y=$$DATE^OCXSENDD(Y)
- if (Y["@")
- SET Y=$PIECE(Y,"@",1)_" at "_$PIECE(Y,"@",2)
- QUIT Y
- +1 ;