- OCXSEND2 ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (File Data) ;3/21/00 07:48
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,74,105**;Dec 17,1997
- ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
- ;
- S ;
- ;
- ;
- N FILE,REC,DD,RECNAME,FNAME
- ;
- S FILE=0 F S FILE=$O(^OCXS(FILE)) Q:'FILE D
- .S ^TMP("OCXSEND",$J,"DATA",$$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("OCXSEND",$J,"DATA",$$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
- .S FNAME=$P(^OCXS(FILE,0),U,1) Q:'$L(FNAME)
- .Q:'($O(^TMP("OCXSEND",$J,"LIST",FILE,0)))
- .S ^TMP("OCXSEND",$J,"DATA",$$NEXT)="SOF^"_(+$P(^OCXS(FILE,0),U,2))_" "_$P(^OCXS(FILE,0),U,1)
- .W !!,"File: ",+FILE," ",FNAME
- .S RECNAME="" F S RECNAME=$O(^TMP("OCXSEND",$J,"LIST",FILE,"B",RECNAME)) Q:'$L(RECNAME) D
- ..S REC=0 F S REC=$O(^TMP("OCXSEND",$J,"LIST",FILE,"B",RECNAME,REC)) Q:'REC D
- ...N REM,ARRAY,DD
- ...S:(FNAME["ORDER CHECK ") FNAME=$P(FNAME,"ORDER CHECK ",2)
- ...S:(FNAME["OCX MDD ") FNAME=$P(FNAME,"OCX MDD ",2)
- ...W !,FILE," ",FNAME,": ",$J(REC,3)," ",$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("OCXSEND",$J,"DATA",$$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("OCXSEND",$J,"DATA",$$NEXT)="R"_U_$P($P(ARRAY,"(",2),")",1)
- ....S ^TMP("OCXSEND",$J,"DATA",$$NEXT)="D"_U_(@ARRAY)
- ...S ^TMP("OCXSEND",$J,"DATA",$$NEXT)="EOR^"
- .S ^TMP("OCXSEND",$J,"DATA",$$NEXT)="EOF^OCXS("_FILE_")^1"
- ;
- Q
- ;
- NEXT() Q $O(^TMP("OCXSEND",$J,"DATA",""),-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 Q:$$WPFLD(DD)
- ;
- I $L($$FILE^OCXSENDD(DD,"NAME")) S PATH=PATH_""""_DD_":""" I 1
- E I (DD["860.41") S PATH=PATH_","""_DD_":"_$G(DATA(DD,D0,.01,"E"))_U_"860.6"""
- E 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^OCXSENDD(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^OCXSENDD(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^OCXSENDD(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^OCXSENDD(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^OCXSENDD(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^OCXSENDD(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
- Q 0
- ;
- WPFLD(X) Q:(X=860.801) 1 Q:(X=860.81) 1 Q:(X=861.01) 1 Q:(X=863.02) 1 Q:(X=863.54) 1
- Q:(X=863.61) 1 Q:(X=863.72) 1 Q:(X=863.81) 1
- Q 0
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOCXSEND2 4420 printed Mar 13, 2025@21:31:24 Page 2
- OCXSEND2 ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (File Data) ;3/21/00 07:48
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,74,105**;Dec 17,1997
- +2 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
- +3 ;
- S ;
- +1 ;
- +2 ;
- +3 NEW FILE,REC,DD,RECNAME,FNAME
- +4 ;
- +5 SET FILE=0
- FOR
- SET FILE=$ORDER(^OCXS(FILE))
- if 'FILE
- QUIT
- Begin DoDot:1
- +6 SET ^TMP("OCXSEND",$JOB,"DATA",$$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("OCXSEND",$JOB,"DATA",$$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 SET FNAME=$PIECE(^OCXS(FILE,0),U,1)
- if '$LENGTH(FNAME)
- QUIT
- +13 if '($ORDER(^TMP("OCXSEND",$JOB,"LIST",FILE,0)))
- QUIT
- +14 SET ^TMP("OCXSEND",$JOB,"DATA",$$NEXT)="SOF^"_(+$PIECE(^OCXS(FILE,0),U,2))_" "_$PIECE(^OCXS(FILE,0),U,1)
- +15 WRITE !!,"File: ",+FILE," ",FNAME
- +16 SET RECNAME=""
- FOR
- SET RECNAME=$ORDER(^TMP("OCXSEND",$JOB,"LIST",FILE,"B",RECNAME))
- if '$LENGTH(RECNAME)
- QUIT
- Begin DoDot:2
- +17 SET REC=0
- FOR
- SET REC=$ORDER(^TMP("OCXSEND",$JOB,"LIST",FILE,"B",RECNAME,REC))
- if 'REC
- QUIT
- Begin DoDot:3
- +18 NEW REM,ARRAY,DD
- +19 if (FNAME["ORDER CHECK ")
- SET FNAME=$PIECE(FNAME,"ORDER CHECK ",2)
- +20 if (FNAME["OCX MDD ")
- SET FNAME=$PIECE(FNAME,"OCX MDD ",2)
- +21 WRITE !,FILE," ",FNAME,": ",$JUSTIFY(REC,3)," ",$PIECE(^OCXS(FILE,REC,0),U,1)," "
- +22 IF (FILE=2)
- IF $GET(^OCXS(860.2,REC,"INACT"))
- WRITE !,?10,"*** Inactive rule skipped. ***"
- QUIT
- +23 DO GETREC("^OCXS("_FILE_",","REM(",REC,.REM)
- +24 SET DD=$ORDER(REM(0))
- +25 SET ^TMP("OCXSEND",$JOB,"DATA",$$NEXT)="KEY"_U_DD_U_REM(DD,.01,"E")
- +26 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:4
- +27 SET ^TMP("OCXSEND",$JOB,"DATA",$$NEXT)="R"_U_$P($PIECE(ARRAY,"(",2),")",1)
- +28 SET ^TMP("OCXSEND",$JOB,"DATA",$$NEXT)="D"_U_(@ARRAY)
- End DoDot:4
- +29 SET ^TMP("OCXSEND",$JOB,"DATA",$$NEXT)="EOR^"
- End DoDot:3
- End DoDot:2
- +30 SET ^TMP("OCXSEND",$JOB,"DATA",$$NEXT)="EOF^OCXS("_FILE_")^1"
- End DoDot:1
- +31 ;
- +32 QUIT
- +33 ;
- NEXT() QUIT $ORDER(^TMP("OCXSEND",$JOB,"DATA",""),-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
- if $$WPFLD(DD)
- QUIT
- +6 ;
- +7 IF $LENGTH($$FILE^OCXSENDD(DD,"NAME"))
- SET PATH=PATH_""""_DD_":"""
- IF 1
- +8 IF '$TEST
- IF (DD["860.41")
- SET PATH=PATH_","""_DD_":"_$GET(DATA(DD,D0,.01,"E"))_U_"860.6"""
- +9 IF '$TEST
- SET PATH=PATH_","""_DD_":"_D0_""""
- +10 MERGE @(PATH_")")=DATA(DD,D0)
- +11 ;
- +12 SET S1=""
- FOR
- SET S1=$ORDER(@(GL_D0_","_$$SUB(S1)_")"))
- if '$LENGTH(S1)
- QUIT
- IF ($DATA(@(GL_D0_","_$$SUB(S1)_")"))>3)
- Begin DoDot:1
- +13 NEW D1,GLREF
- SET GLREF=GL_D0_","_$$SUB(S1)_","
- +14 SET D1=0
- FOR
- SET D1=$ORDER(@(GLREF_D1_")"))
- if 'D1
- QUIT
- DO GETREC(GLREF,PATH,D1,.REM)
- End DoDot:1
- +15 ;
- +16 QUIT
- +17 ;
- 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^OCXSENDD(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^OCXSENDD(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^OCXSENDD(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^OCXSENDD(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^OCXSENDD(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^OCXSENDD(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 QUIT 0
- +12 ;
- WPFLD(X) if (X=860.801)
- QUIT 1
- if (X=860.81)
- QUIT 1
- if (X=861.01)
- QUIT 1
- if (X=863.02)
- QUIT 1
- if (X=863.54)
- QUIT 1
- +1 if (X=863.61)
- QUIT 1
- if (X=863.72)
- QUIT 1
- if (X=863.81)
- QUIT 1
- +2 QUIT 0
- +3 ;
