OCXDI0 ;SLC/RJS,CLA - OCX PACKAGE DIAGNOSTIC UTILITY ROUTINE ;SEP 7,1999 at 10:30
;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997
;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
;
S ;
;
Q
;
RTN(RSUM) ;
;
D DOT^OCXDIAG
;
N CHAR,CSUM,DASH,LINE,MSG,RNDX,RPC,RTN,TEXT,X,RCSM,RDIFF
;
S RCSM(3)="",RTN=$P(RSUM(0),U,1)
F RNDX=1:1 Q:'$D(RSUM(RNDX)) F RPC=1:1:$L(RSUM(RNDX),U) S RCSM($O(RCSM(""),-1)+1)=$P(RSUM(RNDX),U,RPC)
K RCSM(3)
;
S X=RTN X ^%ZOSF("TEST") E D WARN(RTN,"Routine not in local system") Q 0
;
F LINE=4:1 S TEXT=$$TEXT(RTN,LINE) Q:'$L(TEXT) I '$D(RCSM(LINE)) S RDIFF(LINE)=""
S LINE=0 F S LINE=$O(RCSM(LINE)) Q:'LINE S TEXT=$$TEXT(RTN,LINE) D
.S CSUM=0 F CHAR=1:1:$L(TEXT) S CSUM=CSUM+($A(TEXT,CHAR)*CHAR)
.I '(RCSM(LINE)=(+(CSUM_"."_$L(TEXT)_"1"))) S RDIFF(LINE)=""
;
Q:'$O(RDIFF(0)) 0
;
D WARN(RTN,"Checksums do not match",.RDIFF)
;
Q 0
;
WARN(RTN,MSG,LINES) ;
;
Q:$G(OCXAUTO)
;
N DASH,LINE,NLINE,PLINE
;
S DASH="",$P(DASH,"-",(55-$L(MSG)-2))="-"
W !!,"----WARNING-","--",MSG,DASH
;
W !,RTN,?10,"[OEX,OER] -> [",$$CUCI^OCXBDT,"] 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: SEP 7,1999 at 10:30 in UCI: OEX,OER"
W !," Current Date: ",$$NOW," Current UCI: ",$$CUCI^OCXBDT,!!
S LASTFILE=0
K ^TMP("OCXDIAG",$J)
S ^TMP("OCXDIAG",$J)=($P($H,",",2)+($H*86400)+(1*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG"
Q
;
LISTFILE(GLREF,SCANDUP) ;
;
Q:($L(GLREF)<2) 0
N D0,NAME,FILE,QUIT,CNT,FILENUM
S QUIT=0,FILE=$P($G(@GLREF@(0)),U,1),FILENUM=+$P($G(@GLREF@(0)),U,2)
I '$L(FILE) W !!,"Cannot find File: ",GLREF Q $$PAUSE
I SCANDUP S (QUIT,D0)=0 F CNT=0:1 S D0=$O(@GLREF@(D0)) Q:'D0 S NAME=$P($G(@GLREF@(D0,0)),U,1) D Q:QUIT
.D DOT^OCXDIAG
.I '$L(NAME) W !,GLREF," ",FILE," -> Record #",D0," does not have a name." S QUIT=$$PAUSE Q
.I OCXFLGR,'$D(^TMP("OCXDIAG",$J,"A",FILENUM,NAME)) D
..W !!," Extra Record in (L) ",$$CUCI^OCXBDT," - ",FILE,": ",NAME,"."
..S QUIT=$$DELREC^OCXDI2(FILENUM,D0)
Q QUIT
;
GETFILE(FILE,RECNAME,ARRAY) ;
;
N CHECK,GLNEXT,GLREF,LINES,REC,DD,FLD
S REC=$$LOOKUP(FILE,RECNAME)
I 'REC W:OCXFLGR !!,$$FILENAME^OCXBDTD(FILE),": ",RECNAME," not found." Q 0
I (REC=-1) W:OCXFLGR !!,$$FILENAME^OCXBDTD(FILE),": ",RECNAME," duplicate local entries.",! S REC=$$DELDUP^OCXDI2(FILE,RECNAME)
I (REC=-2) W:OCXFLGR !!,$$FILENAME^OCXBDTD(FILE)," (",FILE,") local file not found." W ! Q:$$PAUSE -10 Q REC
I (REC<0) W:OCXFLGR !!,$$FILENAME^OCXBDTD(FILE),": ",RECNAME," unknown error." W ! Q:$$PAUSE -10 Q REC
I (REC>0) D
.S CHECK=0,LINES=0
.D GETREC($$FILE^OCXBDTD(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("OCXDIAG",$J,"B",FILE,KEY,0)) Q 0
N RECNAM,REC,D0,CNT,SHORT S (REC,CNT)=0
S GL=$$FILE^OCXBDTD(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("OCXDIAG",$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^OCXBDTD(DD,"NAME")) S PATH=PATH_""""_DD_":"_D0_""""
I '$L($$FILE^OCXBDTD(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() Q:'OCXFLGC 0 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^OCXBDTD(Y) S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2) Q Y
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOCXDI0 4638 printed Dec 13, 2024@02:22:33 Page 2
OCXDI0 ;SLC/RJS,CLA - OCX PACKAGE DIAGNOSTIC UTILITY ROUTINE ;SEP 7,1999 at 10:30
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997
+2 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
+3 ;
S ;
+1 ;
+2 QUIT
+3 ;
RTN(RSUM) ;
+1 ;
+2 DO DOT^OCXDIAG
+3 ;
+4 NEW CHAR,CSUM,DASH,LINE,MSG,RNDX,RPC,RTN,TEXT,X,RCSM,RDIFF
+5 ;
+6 SET RCSM(3)=""
SET RTN=$PIECE(RSUM(0),U,1)
+7 FOR RNDX=1:1
if '$DATA(RSUM(RNDX))
QUIT
FOR RPC=1:1:$LENGTH(RSUM(RNDX),U)
SET RCSM($ORDER(RCSM(""),-1)+1)=$PIECE(RSUM(RNDX),U,RPC)
+8 KILL RCSM(3)
+9 ;
+10 SET X=RTN
XECUTE ^%ZOSF("TEST")
IF '$TEST
DO WARN(RTN,"Routine not in local system")
QUIT 0
+11 ;
+12 FOR LINE=4:1
SET TEXT=$$TEXT(RTN,LINE)
if '$LENGTH(TEXT)
QUIT
IF '$DATA(RCSM(LINE))
SET RDIFF(LINE)=""
+13 SET LINE=0
FOR
SET LINE=$ORDER(RCSM(LINE))
if 'LINE
QUIT
SET TEXT=$$TEXT(RTN,LINE)
Begin DoDot:1
+14 SET CSUM=0
FOR CHAR=1:1:$LENGTH(TEXT)
SET CSUM=CSUM+($ASCII(TEXT,CHAR)*CHAR)
+15 IF '(RCSM(LINE)=(+(CSUM_"."_$LENGTH(TEXT)_"1")))
SET RDIFF(LINE)=""
End DoDot:1
+16 ;
+17 if '$ORDER(RDIFF(0))
QUIT 0
+18 ;
+19 DO WARN(RTN,"Checksums do not match",.RDIFF)
+20 ;
+21 QUIT 0
+22 ;
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 !!,"----WARNING-","--",MSG,DASH
+8 ;
+9 WRITE !,RTN,?10,"[OEX,OER] -> [",$$CUCI^OCXBDT,"] 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: SEP 7,1999 at 10:30 in UCI: OEX,OER"
+3 WRITE !," Current Date: ",$$NOW," Current UCI: ",$$CUCI^OCXBDT,!!
+4 SET LASTFILE=0
+5 KILL ^TMP("OCXDIAG",$JOB)
+6 SET ^TMP("OCXDIAG",$JOB)=($PIECE($HOROLOG,",",2)+($HOROLOG*86400)+(1*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG"
+7 QUIT
+8 ;
LISTFILE(GLREF,SCANDUP) ;
+1 ;
+2 if ($LENGTH(GLREF)<2)
QUIT 0
+3 NEW D0,NAME,FILE,QUIT,CNT,FILENUM
+4 SET QUIT=0
SET FILE=$PIECE($GET(@GLREF@(0)),U,1)
SET FILENUM=+$PIECE($GET(@GLREF@(0)),U,2)
+5 IF '$LENGTH(FILE)
WRITE !!,"Cannot find File: ",GLREF
QUIT $$PAUSE
+6 IF SCANDUP
SET (QUIT,D0)=0
FOR CNT=0:1
SET D0=$ORDER(@GLREF@(D0))
if 'D0
QUIT
SET NAME=$PIECE($GET(@GLREF@(D0,0)),U,1)
Begin DoDot:1
+7 DO DOT^OCXDIAG
+8 IF '$LENGTH(NAME)
WRITE !,GLREF," ",FILE," -> Record #",D0," does not have a name."
SET QUIT=$$PAUSE
QUIT
+9 IF OCXFLGR
IF '$DATA(^TMP("OCXDIAG",$JOB,"A",FILENUM,NAME))
Begin DoDot:2
+10 WRITE !!," Extra Record in (L) ",$$CUCI^OCXBDT," - ",FILE,": ",NAME,"."
+11 SET QUIT=$$DELREC^OCXDI2(FILENUM,D0)
End DoDot:2
End DoDot:1
if QUIT
QUIT
+12 QUIT QUIT
+13 ;
GETFILE(FILE,RECNAME,ARRAY) ;
+1 ;
+2 NEW CHECK,GLNEXT,GLREF,LINES,REC,DD,FLD
+3 SET REC=$$LOOKUP(FILE,RECNAME)
+4 IF 'REC
if OCXFLGR
WRITE !!,$$FILENAME^OCXBDTD(FILE),": ",RECNAME," not found."
QUIT 0
+5 IF (REC=-1)
if OCXFLGR
WRITE !!,$$FILENAME^OCXBDTD(FILE),": ",RECNAME," duplicate local entries.",!
SET REC=$$DELDUP^OCXDI2(FILE,RECNAME)
+6 IF (REC=-2)
if OCXFLGR
WRITE !!,$$FILENAME^OCXBDTD(FILE)," (",FILE,") local file not found."
WRITE !
if $$PAUSE
QUIT -10
QUIT REC
+7 IF (REC<0)
if OCXFLGR
WRITE !!,$$FILENAME^OCXBDTD(FILE),": ",RECNAME," unknown 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^OCXBDTD(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("OCXDIAG",$JOB,"B",FILE,KEY,0))
QUIT 0
+2 NEW RECNAM,REC,D0,CNT,SHORT
SET (REC,CNT)=0
+3 SET GL=$$FILE^OCXBDTD(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("OCXDIAG",$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^OCXBDTD(DD,"NAME"))
SET PATH=PATH_""""_DD_":"_D0_""""
+8 IF '$LENGTH($$FILE^OCXBDTD(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() if 'OCXFLGC
QUIT 0
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^OCXBDTD(Y)
if (Y["@")
SET Y=$PIECE(Y,"@",1)_" at "_$PIECE(Y,"@",2)
QUIT Y
+1 ;
