- Timestamp:
- Dec 4, 2009, 12:11:15 AM (15 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOCMP8.m
r613 r623 1 OCXOCMP8 ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Assemble Order Check Routines utilities) ;10/29/98 12:37 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,243**;Dec 17,1997;Build 242 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 Q 6 FILE(RNUM) ; 7 ; 8 W:'$G(OCXAUTO) !,$$RNAM(RNUM) 9 N DIE,XCN,X 10 S DIE="^TMP(""OCXCMP"",$J,""D CODE"","_RNUM_",",XCN=0,X=$$RNAM(RNUM) 11 X ^%ZOSF("SAVE") 12 Q 13 ; 14 APPEND(DSUB,CSUB,SRC,LABEL) ; 15 ; 16 N OCXSRC,OCXNDX,OCXNEXT,GLD,GLC 17 S GLD="^TMP(""OCXCMP"",$J,""D CODE"","_(+DSUB)_")" 18 I (CSUB="$") D Q 19 .S OCXNEXT=$O(@GLD@(" "),-1)+1 20 .S @GLD@(OCXNEXT,0)="$" 21 .S OCXNEXT=$O(@GLD@(" "),-1)+1 22 .S @GLD@(OCXNEXT,0)="" 23 ; 24 I (SRC="C") M GLC=^TMP("OCXCMP",$J,"C CODE",+CSUB) S ^TMP("OCXCMP",$J,"D CODE","LINE",LABEL)=DSUB_","_($O(@GLD@(" "),-1)+1) 25 I (SRC="F") M GLC=^TMP("OCXCMP",$J,"INCLUDE",CSUB) 26 S OCXNDX=0 F S OCXNDX=$O(GLC(OCXNDX)) Q:'OCXNDX D 27 .S OCXNEXT=$O(@GLD@(" "),-1)+1 28 .S @GLD@(OCXNEXT,0)=GLC(OCXNDX,0) 29 M @GLD@("CALLS")=GLC("CALLS") 30 S @GLD@("SIZE")=$G(@GLD@("SIZE"))+$G(GLC("SIZE")) 31 Q 32 ; 33 SIZE(DSUB,CSUB) ; 34 ; 35 N D0,EFC,OCXEFC,OCXEFD,OCXEFF,OCXREC 36 N OCXTEMP,PIEC,SIZEC,SIZED,SIZEF,TEXT 37 ; 38 S (SIZEC,SIZED,SIZEF)=0 39 K OCXEFF,OCXEFC,OCXEFD 40 S (OCXEFF,OCXEFC,OCXEFD)="" 41 ; 42 I $G(CSUB),$D(^TMP("OCXCMP",$J,"C CODE",+CSUB)) D 43 .I $D(^TMP("OCXCMP",$J,"C CODE",+CSUB,"SIZE")) D Q 44 ..S SIZEC=^TMP("OCXCMP",$J,"C CODE",+CSUB,"SIZE") 45 ..I $D(^TMP("OCXCMP",$J,"C CODE",+CSUB,"CALLS")) D 46 ...K OCXEFC M OCXEFC=^TMP("OCXCMP",$J,"C CODE",+CSUB,"CALLS") 47 .K OCXREC M OCXREC=^TMP("OCXCMP",$J,"C CODE",+CSUB) 48 .S D0=0 F S D0=$O(OCXREC(D0)) Q:'D0 D 49 ..S TEXT=OCXREC(D0,0),SIZEC=SIZEC+$L(TEXT) 50 ..Q:'(TEXT["$$") 51 ..F PIEC=2:1:$L(TEXT,"$$") D 52 ...S EFC=$P($P(TEXT,"$$",PIEC),"(",1) 53 ...S:(EFC[" ") EFC=$P(EFC," ",1) Q:(EFC["^") Q:'$L(EFC) 54 ...I '$D(^TMP("OCXCMP",$J,"INCLUDE",EFC)) D Q 55 ....D WARN^OCXOCMPV("Unknown Local Extrinsic Function: "_EFC,$P($T(+1)," ",1)) Q 56 ...S OCXEFC(EFC)="" 57 .S SIZEC=SIZEC+100 ; ADJUST FOR SUBROUTINE DOCUMENTATION 58 .S ^TMP("OCXCMP",$J,"C CODE",+CSUB,"SIZE")=SIZEC 59 .M ^TMP("OCXCMP",$J,"C CODE",+CSUB,"CALLS")=OCXEFC 60 ; 61 I $G(DSUB),$D(^TMP("OCXCMP",$J,"D CODE",+DSUB)) D 62 .I $G(^TMP("OCXCMP",$J,"D CODE",+DSUB,"SIZE")) D Q 63 ..S SIZED=^TMP("OCXCMP",$J,"D CODE",+DSUB,"SIZE") 64 ..I $D(^TMP("OCXCMP",$J,"D CODE",+DSUB,"CALLS")) D 65 ...K OCXEFD M OCXEFD=^TMP("OCXCMP",$J,"D CODE",+DSUB,"CALLS") 66 ; 67 K OCXEFF M OCXEFF=OCXEFC,OCXEFF=OCXEFD 68 ; 69 I $D(OCXEFF) S EFC="" F S EFC=$O(OCXEFF(EFC)) Q:'$L(EFC) I 'OCXEFF(EFC) D 70 .K OCXTEMP 71 .I $D(^TMP("OCXCMP",$J,"INCLUDE",EFC,"SIZE")) M OCXTEMP("SIZE")=^TMP("OCXCMP",$J,"INCLUDE",EFC,"SIZE") 72 .I $D(^TMP("OCXCMP",$J,"INCLUDE",EFC,"CALLS")) M OCXTEMP("CALLS")=^TMP("OCXCMP",$J,"INCLUDE",EFC,"CALLS") 73 .S OCXEFF(EFC)=OCXTEMP("SIZE") 74 .Q:'$D(OCXTEMP("CALLS")) 75 .S EFC="" F S EFC=$O(OCXTEMP("CALLS",EFC)) Q:'$L(EFC) S OCXEFF(EFC)=+$G(OCXEFF(EFC)) 76 ; 77 I $D(OCXEFF) S EFC="" F S EFC=$O(OCXEFF(EFC)) Q:'$L(EFC) S SIZEF=SIZEF+OCXEFF(EFC) 78 ; 79 Q $G(SIZEC)+$G(SIZED)+$G(SIZEF) 80 ; 81 RNAM(X) ; 82 N CHAR 83 S CHAR="0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" 84 Q "OCXOZ"_$E(CHAR,(X\36+1))_$E(CHAR,(X#36+1)) 85 ; 86 TODAY() N X,Y,%DT S X="T",%DT="" D ^%DT X ^DD("DD") Q Y 87 ; 88 NOW() N X,Y,%DT S X="N",%DT="T" D ^%DT X ^DD("DD") S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2,99) Q Y 89 ; 1 OCXOCMP8 ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Assemble Order Check Routines utilities) ;6:55 PM 24 Jan 2008 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997;Build 2 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; Modified from FOIA VISTA, 6 ; Copyright (C) 2007 WorldVistA 7 ; 8 ; This program is free software; you can redistribute it and/or modify 9 ; it under the terms of the GNU General Public License as published by 10 ; the Free Software Foundation; either version 2 of the License, or 11 ; (at your option) any later version. 12 ; 13 Q 14 FILE(RNUM) ; 15 ; 16 W:'$G(OCXAUTO) !,$$RNAM(RNUM) 17 N DIE,XCN,X 18 S DIE="^TMP(""OCXCMP"",$J,""D CODE"","_RNUM_",",XCN=0,X=$$RNAM(RNUM) 19 X ^%ZOSF("SAVE") 20 ; 21 ; WVEHR/SO 01/24/08 ;Commented out next 2 lines 22 ; W:'$G(OCXAUTO) " ...",XCM," lines filed." 23 ; S OCXLCNT=$G(OCXLCNT)+XCM 24 ; 25 Q 26 ; 27 APPEND(DSUB,CSUB,SRC,LABEL) ; 28 ; 29 N OCXSRC,OCXNDX,OCXNEXT,GLD,GLC 30 S GLD="^TMP(""OCXCMP"",$J,""D CODE"","_(+DSUB)_")" 31 I (CSUB="$") D Q 32 .S OCXNEXT=$O(@GLD@(" "),-1)+1 33 .S @GLD@(OCXNEXT,0)="$" 34 .S OCXNEXT=$O(@GLD@(" "),-1)+1 35 .S @GLD@(OCXNEXT,0)="" 36 ; 37 I (SRC="C") M GLC=^TMP("OCXCMP",$J,"C CODE",+CSUB) S ^TMP("OCXCMP",$J,"D CODE","LINE",LABEL)=DSUB_","_($O(@GLD@(" "),-1)+1) 38 I (SRC="F") M GLC=^TMP("OCXCMP",$J,"INCLUDE",CSUB) 39 S OCXNDX=0 F S OCXNDX=$O(GLC(OCXNDX)) Q:'OCXNDX D 40 .S OCXNEXT=$O(@GLD@(" "),-1)+1 41 .S @GLD@(OCXNEXT,0)=GLC(OCXNDX,0) 42 M @GLD@("CALLS")=GLC("CALLS") 43 S @GLD@("SIZE")=$G(@GLD@("SIZE"))+$G(GLC("SIZE")) 44 Q 45 ; 46 SIZE(DSUB,CSUB) ; 47 ; 48 N D0,EFC,OCXEFC,OCXEFD,OCXEFF,OCXREC 49 N OCXTEMP,PIEC,SIZEC,SIZED,SIZEF,TEXT 50 ; 51 S (SIZEC,SIZED,SIZEF)=0 52 K OCXEFF,OCXEFC,OCXEFD 53 S (OCXEFF,OCXEFC,OCXEFD)="" 54 ; 55 I $G(CSUB),$D(^TMP("OCXCMP",$J,"C CODE",+CSUB)) D 56 .I $D(^TMP("OCXCMP",$J,"C CODE",+CSUB,"SIZE")) D Q 57 ..S SIZEC=^TMP("OCXCMP",$J,"C CODE",+CSUB,"SIZE") 58 ..I $D(^TMP("OCXCMP",$J,"C CODE",+CSUB,"CALLS")) D 59 ...K OCXEFC M OCXEFC=^TMP("OCXCMP",$J,"C CODE",+CSUB,"CALLS") 60 .K OCXREC M OCXREC=^TMP("OCXCMP",$J,"C CODE",+CSUB) 61 .S D0=0 F S D0=$O(OCXREC(D0)) Q:'D0 D 62 ..S TEXT=OCXREC(D0,0),SIZEC=SIZEC+$L(TEXT) 63 ..Q:'(TEXT["$$") 64 ..F PIEC=2:1:$L(TEXT,"$$") D 65 ...S EFC=$P($P(TEXT,"$$",PIEC),"(",1) 66 ...S:(EFC[" ") EFC=$P(EFC," ",1) Q:(EFC["^") Q:'$L(EFC) 67 ...I '$D(^TMP("OCXCMP",$J,"INCLUDE",EFC)) D Q 68 ....D WARN^OCXOCMPV("Unknown Local Extrinsic Function: "_EFC,$P($T(+1)," ",1)) Q 69 ...S OCXEFC(EFC)="" 70 .S SIZEC=SIZEC+100 ; ADJUST FOR SUBROUTINE DOCUMENTATION 71 .S ^TMP("OCXCMP",$J,"C CODE",+CSUB,"SIZE")=SIZEC 72 .M ^TMP("OCXCMP",$J,"C CODE",+CSUB,"CALLS")=OCXEFC 73 ; 74 I $G(DSUB),$D(^TMP("OCXCMP",$J,"D CODE",+DSUB)) D 75 .I $G(^TMP("OCXCMP",$J,"D CODE",+DSUB,"SIZE")) D Q 76 ..S SIZED=^TMP("OCXCMP",$J,"D CODE",+DSUB,"SIZE") 77 ..I $D(^TMP("OCXCMP",$J,"D CODE",+DSUB,"CALLS")) D 78 ...K OCXEFD M OCXEFD=^TMP("OCXCMP",$J,"D CODE",+DSUB,"CALLS") 79 ; 80 K OCXEFF M OCXEFF=OCXEFC,OCXEFF=OCXEFD 81 ; 82 I $D(OCXEFF) S EFC="" F S EFC=$O(OCXEFF(EFC)) Q:'$L(EFC) I 'OCXEFF(EFC) D 83 .K OCXTEMP 84 .I $D(^TMP("OCXCMP",$J,"INCLUDE",EFC,"SIZE")) M OCXTEMP("SIZE")=^TMP("OCXCMP",$J,"INCLUDE",EFC,"SIZE") 85 .I $D(^TMP("OCXCMP",$J,"INCLUDE",EFC,"CALLS")) M OCXTEMP("CALLS")=^TMP("OCXCMP",$J,"INCLUDE",EFC,"CALLS") 86 .S OCXEFF(EFC)=OCXTEMP("SIZE") 87 .Q:'$D(OCXTEMP("CALLS")) 88 .S EFC="" F S EFC=$O(OCXTEMP("CALLS",EFC)) Q:'$L(EFC) S OCXEFF(EFC)=+$G(OCXEFF(EFC)) 89 ; 90 I $D(OCXEFF) S EFC="" F S EFC=$O(OCXEFF(EFC)) Q:'$L(EFC) S SIZEF=SIZEF+OCXEFF(EFC) 91 ; 92 Q $G(SIZEC)+$G(SIZED)+$G(SIZEF) 93 ; 94 RNAM(X) ; 95 N CHAR 96 S CHAR="0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" 97 Q "OCXOZ"_$E(CHAR,(X\36+1))_$E(CHAR,(X#36+1)) 98 ; 99 TODAY() N X,Y,%DT S X="T",%DT="" D ^%DT X ^DD("DD") Q Y 100 ; 101 NOW() N X,Y,%DT S X="N",%DT="T" D ^%DT X ^DD("DD") S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2,99) Q Y 102 ;
Note:
See TracChangeset
for help on using the changeset viewer.
