- OCXBDT3 ;SLC/RJS,CLA - BUILD OCX PACKAGE DIAGNOSTIC ROUTINES (Build Routines) ;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
- ;
- EN() ;
- ;
- N LAST,RLINE,RNUM,RTEXT,TOTLINE
- K ^TMP("OCXBDT",$J,"RTN") S ^TMP("OCXBDT",$J,"RTN",100,0)=" ;"
- S (TOTLINE,RSIZE,RLINE,RCNT)=0,RNUM=1 F S RLINE=$O(^TMP("OCXBDT",$J,RLINE)) Q:'RLINE D
- .S RTEXT=$G(^TMP("OCXBDT",$J,RLINE)) Q:'$L(RTEXT)
- .S LAST=$O(^TMP("OCXBDT",$J,"RTN",""),-1)+1,RCNT=RCNT+1,RSIZE=RSIZE+$L(RTEXT)
- .S ^TMP("OCXBDT",$J,"RTN",LAST,0)=" ;;"_RTEXT
- .I (RSIZE>4000) S TOTLINE=TOTLINE+$$RFILE($O(^TMP("OCXBDT",$J,RLINE)),.RNUM) S (RSIZE,RCNT)=0
- I $O(^TMP("OCXBDT",$J,"RTN",100)) S TOTLINE=TOTLINE+$$RFILE(0,.RNUM)
- ;
- Q TOTLINE
- ;
- RFILE(LINK,RNUM) ;
- ;
- N DIE,LAST,X,XCN,XCM
- D HDR(LINK,RNUM)
- S LAST=$O(^TMP("OCXBDT",$J,"RTN",""),-1)+1
- S ^TMP("OCXBDT",$J,"RTN",LAST,0)=" ;1;"
- S ^TMP("OCXBDT",$J,"RTN",LAST+1,0)=" ;"
- S ^TMP("OCXBDT",$J,"RTN",LAST+2,0)="$"
- S DIE="^TMP(""OCXBDT"","_$J_",""RTN"",",XCN=0
- S X=$$RNAME(RNUM)
- W !,X
- X ^%ZOSF("SAVE")
- W " ... ",XCM," Lines filed"
- S RNUM=RNUM+1
- K ^TMP("OCXBDT",$J,"RTN") S ^TMP("OCXBDT",$J,"RTN",100,0)=" ;"
- Q XCM
- ;
- NOW() ;
- N X,Y,%DT
- S X="N",%DT="T" D ^%DT S Y=$$DATE^OCXBDTD(Y)
- I (Y["@") S Y=$P(Y,"@",1)_" at "_$P(Y,"@",2)
- Q Y
- ;
- HDR(LINK,RNUM) ;
- ;
- N R,LINE,TEXT,RNAME,RLINK,NOW
- S NOW=$$NOW
- I 'LINK S RLINK=";"
- E S RLINK="G ^"_$$RNAME(RNUM+1)
- S RNAME=$$RNAME(RNUM),(HEADER1,HEADER2,HEADER3,HEADER4,HEADER5)=";"
- ;
- F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV(TEXT)
- ;
- M ^TMP("OCXBDT",$J,"RTN")=R
- ;
- Q
- ;
- HEX(X) Q:'X "" Q $$HEX(X\36)_$E("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",((X#36)+1))
- ;
- RNAME(X) Q:'X "" S X=$$HEX(X) Q "OCXDI"_$E("000",$L(X),2)_X
- ;
- CONV(X) ;
- F Q:'(X["|") S X=$P(X,"|",1)_(@$P(X,"|",2))_$P(X,"|",3,999)
- I '(X="$"),'$L($P(X," ",2)) S X=X_" ;"
- Q X
- ;
- TEXT ;
- ;;|RNAME| ;SLC/RJS,CLA - OCX PACKAGE DIAGNOSTIC ROUTINES ;|NOW|
- ;;|OCXLIN2|
- ;;|OCXLIN3|
- ;; ;
- ;;S ;
- ;; ;
- ;; D DOT^OCXDIAG
- ;; ;
- ;; ;
- ;; K REMOTE,LOCAL,OPCODE,REF
- ;; F LINE=1:1:500 S TEXT=$P($T(DATA+LINE),";",2,999) Q:TEXT I $L(TEXT) D Q:QUIT
- ;; .S ^TMP("OCXDIAG",$J,$O(^TMP("OCXDIAG",$J,"A"),-1)+1)=TEXT
- ;; ;
- ;; |RLINK|
- ;; ;
- ;; Q
- ;; ;
- ;;DATA ;
- ;1;
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOCXBDT3 2400 printed Feb 18, 2025@23:48:50 Page 2
- OCXBDT3 ;SLC/RJS,CLA - BUILD OCX PACKAGE DIAGNOSTIC ROUTINES (Build Routines) ;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 ;
- EN() ;
- +1 ;
- +2 NEW LAST,RLINE,RNUM,RTEXT,TOTLINE
- +3 KILL ^TMP("OCXBDT",$JOB,"RTN")
- SET ^TMP("OCXBDT",$JOB,"RTN",100,0)=" ;"
- +4 SET (TOTLINE,RSIZE,RLINE,RCNT)=0
- SET RNUM=1
- FOR
- SET RLINE=$ORDER(^TMP("OCXBDT",$JOB,RLINE))
- if 'RLINE
- QUIT
- Begin DoDot:1
- +5 SET RTEXT=$GET(^TMP("OCXBDT",$JOB,RLINE))
- if '$LENGTH(RTEXT)
- QUIT
- +6 SET LAST=$ORDER(^TMP("OCXBDT",$JOB,"RTN",""),-1)+1
- SET RCNT=RCNT+1
- SET RSIZE=RSIZE+$LENGTH(RTEXT)
- +7 SET ^TMP("OCXBDT",$JOB,"RTN",LAST,0)=" ;;"_RTEXT
- +8 IF (RSIZE>4000)
- SET TOTLINE=TOTLINE+$$RFILE($ORDER(^TMP("OCXBDT",$JOB,RLINE)),.RNUM)
- SET (RSIZE,RCNT)=0
- End DoDot:1
- +9 IF $ORDER(^TMP("OCXBDT",$JOB,"RTN",100))
- SET TOTLINE=TOTLINE+$$RFILE(0,.RNUM)
- +10 ;
- +11 QUIT TOTLINE
- +12 ;
- RFILE(LINK,RNUM) ;
- +1 ;
- +2 NEW DIE,LAST,X,XCN,XCM
- +3 DO HDR(LINK,RNUM)
- +4 SET LAST=$ORDER(^TMP("OCXBDT",$JOB,"RTN",""),-1)+1
- +5 SET ^TMP("OCXBDT",$JOB,"RTN",LAST,0)=" ;1;"
- +6 SET ^TMP("OCXBDT",$JOB,"RTN",LAST+1,0)=" ;"
- +7 SET ^TMP("OCXBDT",$JOB,"RTN",LAST+2,0)="$"
- +8 SET DIE="^TMP(""OCXBDT"","_$JOB_",""RTN"","
- SET XCN=0
- +9 SET X=$$RNAME(RNUM)
- +10 WRITE !,X
- +11 XECUTE ^%ZOSF("SAVE")
- +12 WRITE " ... ",XCM," Lines filed"
- +13 SET RNUM=RNUM+1
- +14 KILL ^TMP("OCXBDT",$JOB,"RTN")
- SET ^TMP("OCXBDT",$JOB,"RTN",100,0)=" ;"
- +15 QUIT XCM
- +16 ;
- NOW() ;
- +1 NEW X,Y,%DT
- +2 SET X="N"
- SET %DT="T"
- DO ^%DT
- SET Y=$$DATE^OCXBDTD(Y)
- +3 IF (Y["@")
- SET Y=$PIECE(Y,"@",1)_" at "_$PIECE(Y,"@",2)
- +4 QUIT Y
- +5 ;
- HDR(LINK,RNUM) ;
- +1 ;
- +2 NEW R,LINE,TEXT,RNAME,RLINK,NOW
- +3 SET NOW=$$NOW
- +4 IF 'LINK
- SET RLINK=";"
- +5 IF '$TEST
- SET RLINK="G ^"_$$RNAME(RNUM+1)
- +6 SET RNAME=$$RNAME(RNUM)
- SET (HEADER1,HEADER2,HEADER3,HEADER4,HEADER5)=";"
- +7 ;
- +8 FOR LINE=1:1:999
- SET TEXT=$PIECE($TEXT(TEXT+LINE),";",2,999)
- if TEXT
- QUIT
- SET TEXT=$PIECE(TEXT,";",2,999)
- SET R(LINE,0)=$$CONV(TEXT)
- +9 ;
- +10 MERGE ^TMP("OCXBDT",$JOB,"RTN")=R
- +11 ;
- +12 QUIT
- +13 ;
- HEX(X) if 'X
- QUIT ""
- QUIT $$HEX(X\36)_$EXTRACT("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",((X#36)+1))
- +1 ;
- RNAME(X) if 'X
- QUIT ""
- SET X=$$HEX(X)
- QUIT "OCXDI"_$EXTRACT("000",$LENGTH(X),2)_X
- +1 ;
- CONV(X) ;
- +1 FOR
- if '(X["|")
- QUIT
- SET X=$PIECE(X,"|",1)_(@$PIECE(X,"|",2))_$PIECE(X,"|",3,999)
- +2 IF '(X="$")
- IF '$LENGTH($PIECE(X," ",2))
- SET X=X_" ;"
- +3 QUIT X
- +4 ;
- TEXT ;
- +1 ;;|RNAME| ;SLC/RJS,CLA - OCX PACKAGE DIAGNOSTIC ROUTINES ;|NOW|
- +2 ;;|OCXLIN2|
- +3 ;;|OCXLIN3|
- +4 ;; ;
- +5 ;;S ;
- +6 ;; ;
- +7 ;; D DOT^OCXDIAG
- +8 ;; ;
- +9 ;; ;
- +10 ;; K REMOTE,LOCAL,OPCODE,REF
- +11 ;; F LINE=1:1:500 S TEXT=$P($T(DATA+LINE),";",2,999) Q:TEXT I $L(TEXT) D Q:QUIT
- +12 ;; .S ^TMP("OCXDIAG",$J,$O(^TMP("OCXDIAG",$J,"A"),-1)+1)=TEXT
- +13 ;; ;
- +14 ;; |RLINK|
- +15 ;; ;
- +16 ;; Q
- +17 ;; ;
- +18 ;;DATA ;
- +19 ;1;
- +20 ;
