OCXBDT2 ;SLC/RJS,CLA - BUILD OCX PACKAGE DIAGNOSTIC ROUTINES (File Data) ;8/04/98 13:21
;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997
;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
;
S ;
;
;
N FILE,REC,DD,RECNAME
;
S FILE=0 F S FILE=$O(^OCXS(FILE)) Q:'FILE D
.S ^TMP("OCXBDT",$J,$$NEXT)="ROOT^OCXS("_(+FILE)_",0)^"_$P(^OCXS(FILE,0),U,1,2)
S FILE=0 F S FILE=$O(^OCXD(FILE)) Q:'FILE D
.S ^TMP("OCXBDT",$J,$$NEXT)="ROOT^OCXD("_(+FILE)_",0)^"_$P(^OCXD(FILE,0),U,1,2)
;
F FILE=38,41,40,37,39,36,35,34,32,31,33,30,9,8,6,5,4,3,2 D
.S FILE=FILE/10+860
.Q:'($O(^OCXS(FILE,0))) Q:'$L($P(^OCXS(FILE,0),U,1))
.S ^TMP("OCXBDT",$J,$$NEXT)="SOF^"_(+$P(^OCXS(FILE,0),U,2))_" "_$P(^OCXS(FILE,0),U,1)
.W !!,"File: ",+FILE," ",$P(^OCXS(FILE,0),U,1)
.S REC=0 F S REC=$O(^OCXS(FILE,REC)) Q:'REC D
..N REM,ARRAY,DD
..W !,FILE," ",$P(^OCXS(FILE,0),U,1),": ",$J(REC,6)," ",$P(^OCXS(FILE,REC,0),U,1)," "
..I (FILE=2),$G(^OCXS(860.2,REC,"INACT")) W !,?10,"*** Inactive rule skipped. ***" Q
..D GETREC("^OCXS("_FILE_",","REM(",REC,.REM)
..S DD=$O(REM(0))
..S ^TMP("OCXBDT",$J,$$NEXT)="KEY"_U_DD_U_REM(DD,.01,"E")
..S ARRAY="REM(0)" F S ARRAY=$Q(@ARRAY) Q:'$L(ARRAY) Q:'($E(ARRAY,1,4)="REM(") I $L(@ARRAY) D
...S ^TMP("OCXBDT",$J,$$NEXT)="R"_U_$P($P(ARRAY,"(",2),")",1)
...S ^TMP("OCXBDT",$J,$$NEXT)="D"_U_(@ARRAY)
..S ^TMP("OCXBDT",$J,$$NEXT)="EOR^"
.S ^TMP("OCXBDT",$J,$$NEXT)="EOF^OCXS("_FILE_")^1"
;
Q
;
NEXT() Q $O(^TMP("OCXBDT",$J,""),-1)+1
;
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_":"""
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,DD,D0,FLD
S DR=".01:99999",DIQ="OCXARY(",DIQ(0)="IEN" D EN^DIQ1
;
S DD=0 F S DD=$O(OCXARY(DD)) Q:'DD D
.S D0=0 F S D0=$O(OCXARY(DD,D0)) Q:'D0 D
..S FLD=0 F S FLD=$O(OCXARY(DD,D0,FLD)) Q:'FLD D
...I $L($$FIELD^OCXBDTD(DD,FLD,"POINTER")),$L($G(OCXARY(DD,D0,FLD,"E"))),$L($G(OCXARY(DD,D0,FLD,"I"))),(OCXARY(DD,D0,FLD,"E")=OCXARY(DD,D0,FLD,"I")) D Q
....N OCXPNTR
....S OCXPNTR=$$FIELD^OCXBDTD(DD,FLD,"POINTER")
....I $L(OCXPNTR) S OCXPNTR="^"_OCXPNTR_"0)"
....I $D(@OCXPNTR) S OCXPNTR=$P(@OCXPNTR,"^",1)
....W !!,"Broken pointer '",OCXARY(DD,D0,FLD,"E"),"'"
....W " (",$$FIELD^OCXBDTD(DD,FLD,"LABEL"),") to"
....W " '",OCXPNTR,"' file (",DD,",",D0,",",FLD,")"
....W !," Not included."
....I (FLD=.01) K OCXARY(DD,D0)
....E K OCXARY(DD,D0,FLD)
...K OCXARY(DD,D0,FLD,"I")
...K:'$L($G(OCXARY(DD,D0,FLD,"E"))) OCXARY(DD,D0,FLD,"E")
...K:$$EXFLD(DD,FLD) OCXARY(DD,D0,FLD)
..;
..I ($$FIELD^OCXBDTD(DD,.01,"LABEL")["PARAMETER"),($G(OCXARY(DD,D0,.01,"E"))="DATA TYPE"),$G(OCXARY(DD,D0,1,"E")) D
...I $D(^OCXS(864.1,+OCXARY(DD,D0,1,"E"),0)) S OCXARY(DD,D0,1,"E")=$P(^OCXS(864.1,+OCXARY(DD,D0,1,"E"),0),U,1)
..;
..I ($$FIELD^OCXBDTD(DD,.01,"LABEL")["PARAMETER"),($G(OCXARY(DD,D0,.01,"E"))="OCXO GENERATE CODE FUNCTION"),$G(OCXARY(DD,D0,1,"E")) D
...I $D(^OCXS(863.7,+OCXARY(DD,D0,1,"E"),0)) S OCXARY(DD,D0,1,"E")=$P(^OCXS(863.7,+OCXARY(DD,D0,1,"E"),0),U,1)
..;
;
Q
EXFLD(FILE,OCXFLD) ;
;
N OCXFNAM
S OCXFNAM=$$FIELD^OCXBDTD(FILE,OCXFLD,"LABEL")
I (OCXFNAM["UNIQUE OBJECT IDENTIFIER") Q 1
I ($E(OCXFNAM,1)="*") Q 1
I (FILE=860.2),(OCXFLD=.02) Q 1
I (FILE=860.22),(OCXFLD=4) Q 1
I (FILE=860.3),(OCXFLD=3) Q 1
I (FILE=860.9),(OCXFLD=1) Q 1
I (FILE=860.91) Q 1
I (FILE=19),(OCXFLD=.15) Q 1
I (FILE=19),(OCXFLD=.16) Q 1
I (FILE=19),(OCXFLD=.26) Q 1
I (FILE=19),(OCXFLD=1.1) Q 1
I (FILE=19),(OCXFLD=3.6) Q 1
I (FILE=19),(OCXFLD=14) Q 1
I (FILE=19),(OCXFLD=99) Q 1
I (FILE=19),(OCXFLD=99.1) Q 1
I (FILE=19),(OCXFLD=200) Q 1
I (FILE=19),(OCXFLD=201) Q 1
I (FILE=19),(OCXFLD=203) Q 1
Q 0
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOCXBDT2 4202 printed Dec 13, 2024@02:22:22 Page 2
OCXBDT2 ;SLC/RJS,CLA - BUILD OCX PACKAGE DIAGNOSTIC ROUTINES (File Data) ;8/04/98 13:21
+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 ;
+3 NEW FILE,REC,DD,RECNAME
+4 ;
+5 SET FILE=0
FOR
SET FILE=$ORDER(^OCXS(FILE))
if 'FILE
QUIT
Begin DoDot:1
+6 SET ^TMP("OCXBDT",$JOB,$$NEXT)="ROOT^OCXS("_(+FILE)_",0)^"_$P(^OCXS(FILE,0),U,1,2)
End DoDot:1
+7 SET FILE=0
FOR
SET FILE=$ORDER(^OCXD(FILE))
if 'FILE
QUIT
Begin DoDot:1
+8 SET ^TMP("OCXBDT",$JOB,$$NEXT)="ROOT^OCXD("_(+FILE)_",0)^"_$P(^OCXD(FILE,0),U,1,2)
End DoDot:1
+9 ;
+10 FOR FILE=38,41,40,37,39,36,35,34,32,31,33,30,9,8,6,5,4,3,2
Begin DoDot:1
+11 SET FILE=FILE/10+860
+12 if '($ORDER(^OCXS(FILE,0)))
QUIT
if '$LENGTH($PIECE(^OCXS(FILE,0),U,1))
QUIT
+13 SET ^TMP("OCXBDT",$JOB,$$NEXT)="SOF^"_(+$PIECE(^OCXS(FILE,0),U,2))_" "_$PIECE(^OCXS(FILE,0),U,1)
+14 WRITE !!,"File: ",+FILE," ",$PIECE(^OCXS(FILE,0),U,1)
+15 SET REC=0
FOR
SET REC=$ORDER(^OCXS(FILE,REC))
if 'REC
QUIT
Begin DoDot:2
+16 NEW REM,ARRAY,DD
+17 WRITE !,FILE," ",$PIECE(^OCXS(FILE,0),U,1),": ",$JUSTIFY(REC,6)," ",$PIECE(^OCXS(FILE,REC,0),U,1)," "
+18 IF (FILE=2)
IF $GET(^OCXS(860.2,REC,"INACT"))
WRITE !,?10,"*** Inactive rule skipped. ***"
QUIT
+19 DO GETREC("^OCXS("_FILE_",","REM(",REC,.REM)
+20 SET DD=$ORDER(REM(0))
+21 SET ^TMP("OCXBDT",$JOB,$$NEXT)="KEY"_U_DD_U_REM(DD,.01,"E")
+22 SET ARRAY="REM(0)"
FOR
SET ARRAY=$QUERY(@ARRAY)
if '$LENGTH(ARRAY)
QUIT
if '($EXTRACT(ARRAY,1,4)="REM(")
QUIT
IF $LENGTH(@ARRAY)
Begin DoDot:3
+23 SET ^TMP("OCXBDT",$JOB,$$NEXT)="R"_U_$P($PIECE(ARRAY,"(",2),")",1)
+24 SET ^TMP("OCXBDT",$JOB,$$NEXT)="D"_U_(@ARRAY)
End DoDot:3
+25 SET ^TMP("OCXBDT",$JOB,$$NEXT)="EOR^"
End DoDot:2
+26 SET ^TMP("OCXBDT",$JOB,$$NEXT)="EOF^OCXS("_FILE_")^1"
End DoDot:1
+27 ;
+28 QUIT
+29 ;
NEXT() QUIT $ORDER(^TMP("OCXBDT",$JOB,""),-1)+1
+1 ;
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_":"""
+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,DD,D0,FLD
+2 SET DR=".01:99999"
SET DIQ="OCXARY("
SET DIQ(0)="IEN"
DO EN^DIQ1
+3 ;
+4 SET DD=0
FOR
SET DD=$ORDER(OCXARY(DD))
if 'DD
QUIT
Begin DoDot:1
+5 SET D0=0
FOR
SET D0=$ORDER(OCXARY(DD,D0))
if 'D0
QUIT
Begin DoDot:2
+6 SET FLD=0
FOR
SET FLD=$ORDER(OCXARY(DD,D0,FLD))
if 'FLD
QUIT
Begin DoDot:3
+7 IF $LENGTH($$FIELD^OCXBDTD(DD,FLD,"POINTER"))
IF $LENGTH($GET(OCXARY(DD,D0,FLD,"E")))
IF $LENGTH($GET(OCXARY(DD,D0,FLD,"I")))
IF (OCXARY(DD,D0,FLD,"E")=OCXARY(DD,D0,FLD,"I"))
Begin DoDot:4
+8 NEW OCXPNTR
+9 SET OCXPNTR=$$FIELD^OCXBDTD(DD,FLD,"POINTER")
+10 IF $LENGTH(OCXPNTR)
SET OCXPNTR="^"_OCXPNTR_"0)"
+11 IF $DATA(@OCXPNTR)
SET OCXPNTR=$PIECE(@OCXPNTR,"^",1)
+12 WRITE !!,"Broken pointer '",OCXARY(DD,D0,FLD,"E"),"'"
+13 WRITE " (",$$FIELD^OCXBDTD(DD,FLD,"LABEL"),") to"
+14 WRITE " '",OCXPNTR,"' file (",DD,",",D0,",",FLD,")"
+15 WRITE !," Not included."
+16 IF (FLD=.01)
KILL OCXARY(DD,D0)
+17 IF '$TEST
KILL OCXARY(DD,D0,FLD)
End DoDot:4
QUIT
+18 KILL OCXARY(DD,D0,FLD,"I")
+19 if '$LENGTH($GET(OCXARY(DD,D0,FLD,"E")))
KILL OCXARY(DD,D0,FLD,"E")
+20 if $$EXFLD(DD,FLD)
KILL OCXARY(DD,D0,FLD)
End DoDot:3
+21 ;
+22 IF ($$FIELD^OCXBDTD(DD,.01,"LABEL")["PARAMETER")
IF ($GET(OCXARY(DD,D0,.01,"E"))="DATA TYPE")
IF $GET(OCXARY(DD,D0,1,"E"))
Begin DoDot:3
+23 IF $DATA(^OCXS(864.1,+OCXARY(DD,D0,1,"E"),0))
SET OCXARY(DD,D0,1,"E")=$PIECE(^OCXS(864.1,+OCXARY(DD,D0,1,"E"),0),U,1)
End DoDot:3
+24 ;
+25 IF ($$FIELD^OCXBDTD(DD,.01,"LABEL")["PARAMETER")
IF ($GET(OCXARY(DD,D0,.01,"E"))="OCXO GENERATE CODE FUNCTION")
IF $GET(OCXARY(DD,D0,1,"E"))
Begin DoDot:3
+26 IF $DATA(^OCXS(863.7,+OCXARY(DD,D0,1,"E"),0))
SET OCXARY(DD,D0,1,"E")=$PIECE(^OCXS(863.7,+OCXARY(DD,D0,1,"E"),0),U,1)
End DoDot:3
+27 ;
End DoDot:2
End DoDot:1
+28 ;
+29 QUIT
EXFLD(FILE,OCXFLD) ;
+1 ;
+2 NEW OCXFNAM
+3 SET OCXFNAM=$$FIELD^OCXBDTD(FILE,OCXFLD,"LABEL")
+4 IF (OCXFNAM["UNIQUE OBJECT IDENTIFIER")
QUIT 1
+5 IF ($EXTRACT(OCXFNAM,1)="*")
QUIT 1
+6 IF (FILE=860.2)
IF (OCXFLD=.02)
QUIT 1
+7 IF (FILE=860.22)
IF (OCXFLD=4)
QUIT 1
+8 IF (FILE=860.3)
IF (OCXFLD=3)
QUIT 1
+9 IF (FILE=860.9)
IF (OCXFLD=1)
QUIT 1
+10 IF (FILE=860.91)
QUIT 1
+11 IF (FILE=19)
IF (OCXFLD=.15)
QUIT 1
+12 IF (FILE=19)
IF (OCXFLD=.16)
QUIT 1
+13 IF (FILE=19)
IF (OCXFLD=.26)
QUIT 1
+14 IF (FILE=19)
IF (OCXFLD=1.1)
QUIT 1
+15 IF (FILE=19)
IF (OCXFLD=3.6)
QUIT 1
+16 IF (FILE=19)
IF (OCXFLD=14)
QUIT 1
+17 IF (FILE=19)
IF (OCXFLD=99)
QUIT 1
+18 IF (FILE=19)
IF (OCXFLD=99.1)
QUIT 1
+19 IF (FILE=19)
IF (OCXFLD=200)
QUIT 1
+20 IF (FILE=19)
IF (OCXFLD=201)
QUIT 1
+21 IF (FILE=19)
IF (OCXFLD=203)
QUIT 1
+22 QUIT 0
+23 ;
