OCXOCMPI ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Build LIST Function Code) ;10/29/98 12:37
;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997
;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
;
Q
;
GETCODE(OCXD0,OCXLIST) ;
;
Q:$G(OCXWARN) 1
;
N OCXNDX
;
S OCXNDX=0 F S OCXNDX=$O(OCXLIST(OCXNDX)) Q:'OCXNDX D Q:OCXWARN
.I OCXLIST(OCXNDX) D Q:OCXWARN
..N OCXPAR,OCXELE,OCXPC,OCXCODE,OCXVAR
..S OCXPAR=$P(OCXLIST(OCXNDX)," ",3,999),OCXELE=+OCXLIST(OCXNDX)
..;
..F OCXPC=2:2:$L(OCXPAR,"|") D Q:OCXWARN
...N OCXDF S OCXDF=+$$DATAFLD($P($P(OCXPAR,"|",OCXPC),"|",1),OCXELE)
...I 'OCXDF D WARN^OCXOCMPV("1 Data Field '"_$P($P(OCXPAR,"|",OCXPC),"|",1)_"' not defined for '("_OCXCON_") "_$P($G(^OCXS(860.6,OCXCON,0)),U,1)_"' data context.",2,OCXD0,$P($T(+1)," ",1)) Q
...S $P(OCXPAR,"|",OCXPC)=OCXDF
..;
..S OCXVAR="OCXLX"_(+OCXNDX)
..S OCXLIST(OCXNDX,"CODE",1)="I $$MCE"_(+OCXELE)_" D @@@@"
.;
.I 'OCXLIST(OCXNDX) D
..;
..N OCXEXP,OCXDTYP,OCXCD
..S OCXEXP=OCXLIST(OCXNDX),OCXDTYP=""
..;
..F OCXPC=2:2:$L(OCXEXP,"|") D Q:OCXWARN
...N OCXELE,OCXDF,OCXDFN,OCXSTR,OCXENDX,OCXNVAL,OCXCON
...S OCXSTR=$P($P(OCXEXP,"|",OCXPC),"|",1),OCXELE=$P(OCXSTR,".",1)
...S OCXDF=$P(OCXSTR,".",2),OCXENDX=+$G(OCXLIST("B",OCXELE))
...S:$L(OCXELE) OCXELE=+$G(OCXLIST(OCXENDX))
...S OCXCON=+$P($G(^OCXS(860.3,+OCXELE,0)),U,2)
...I 'OCXELE D WARN^OCXOCMPV("Label '"_$P(OCXSTR,".",1)_"' not defined.",2,OCXD0,$P($T(+1)," ",1)) Q
...S OCXDFN=+$$DATAFLD(OCXDF,OCXELE)
...I 'OCXDFN D WARN^OCXOCMPV("2 Data Field '"_OCXSTR_"' not defined for '"_$P($G(^OCXS(860.6,+OCXCON,0)),U,1)_"' data context.",2,OCXD0,$P($T(+1)," ",1)) Q
...S OCXNVAL="$G(^TMP(""""OCXCHK"""",$J,DFN,"_(+OCXELE)_","_(+OCXDFN)_"))"
...S $P(OCXEXP,"|",OCXPC)=OCXNVAL
...I $L(OCXDTYP),'(OCXDTYP=$$GETDTYP(+OCXDFN,+OCXCON)) D Q
....D WARN^OCXOCMPV("Invalid Expression, Cannot compare '"_OCXDTYP_"' data with '"_$$GETDTYP(+OCXDFN,+OCXCON)_"' data. ",2,OCXD0,$P($T(+1)," ",1)) Q
...I '$L(OCXDTYP) S OCXDTYP=$$GETDTYP(+OCXDFN,OCXCON)
..I '$L(OCXDTYP) D WARN^OCXOCMPV("Data Type for '"_OCXLIST(OCXNDX,"LABEL")_"' not defined. ",2,OCXD0,$P($T(+1)," ",1)) Q
..;
..; GET EXPRESSION CONDITIONAL EVALUATION CODE
..;
..S OCXCD="",OCXWARN=$$GETC^OCXOCMPL(OCXD0,OCXEXP,OCXDTYP,.OCXCD)
..S OCXLIST(OCXNDX,"CODE",1)=OCXCD
.;
.S OCXWARN='$D(OCXLIST(OCXNDX,"CODE"))
;
Q OCXWARN
;
DATAFLD(OCXFNAM,OCXEL) ;
;
N OCXDFN,OCXCON,OCXLINK
S OCXCON=+$P($G(^OCXS(860.3,+OCXEL,0)),U,2),OCXDFN=$O(^OCXS(860.4,"B",OCXFNAM,0))
Q:'$L($G(OCXFNAM)) 0 Q:'OCXCON 0
S OCXLINK=0 F S OCXLINK=$O(^OCXS(860.4,OCXDFN,"LINK",OCXLINK)) Q:'OCXLINK Q:(OCXLINK=OCXCON)
Q:OCXLINK +OCXDFN Q 0
;
GETDTYP(OCXDF,OCXCON) ;
;
N OCXLINK,OCXATT
S OCXDF=+$G(OCXDF),OCXCON=+$G(OCXCON)
Q:'OCXDF "" Q:'OCXCON ""
S OCXLINK=$G(^OCXS(860.4,+OCXDF,"LINK",OCXCON,"DATAPATH"))
Q:'$L(OCXLINK) ""
S OCXLINK=$O(^OCXS(863.3,"B",OCXLINK,0)) Q:'OCXLINK ""
S OCXATT=$P($G(^OCXS(863.3,OCXLINK,0)),U,5) Q:'OCXATT ""
Q $$GETPARM(34,OCXATT,"DATA TYPE")
;
GETPARM(FILE,INST,PARM) ;
Q:'$L(FILE) "" Q:'$L(INST) "" Q:'$L(PARM) ""
N OCXP,OCXP1,OCXI,OCXGL
S OCXGL="^OCXS" S:(FILE=1) OCXGL="^OCXD" S:(FILE=7) OCXGL="^OCXD" S:(FILE=10) OCXGL="^OCXD" S FILE=FILE/10+860
Q:'$D(@OCXGL@(+FILE,0)) ""
I (PARM=+PARM),$D(^OCXS(863.8,PARM,0)) S OCXP=PARM
E S OCXP=$O(^OCXS(863.8,"B",PARM,0))
Q:'OCXP ""
I (INST=+INST),$D(@OCXGL@(FILE,INST,0)) S OCXI=INST
E S OCXI=$O(@OCXGL@(FILE,"B",INST,0))
Q:'OCXI "" S OCXP1=$O(@OCXGL@(FILE,OCXI,"PAR","B",OCXP,0)) Q:'OCXP1 ""
Q $G(@OCXGL@(FILE,OCXI,"PAR",OCXP1,"VAL"))
;
LAST(ROOT,ELEM,INDEX,PARAM,CD) Q $$LAST^OCXOCMPJ(ROOT,ELEM,INDEX,PARAM,.CD)
FIRST(ROOT,ELEM,INDEX,PARAM,CD) Q $$FIRST^OCXOCMPJ(ROOT,ELEM,INDEX,PARAM,.CD)
RANGE(ROOT,ELEM,INDEX,PARAM,CD) Q $$RANGE^OCXOCMPK(ROOT,ELEM,INDEX,PARAM,.CD)
ANY(ROOT,ELEM,INDEX,PARAM,CD) Q $$ANY^OCXOCMPK(ROOT,ELEM,INDEX,PARAM,.CD)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOCXOCMPI 3956 printed Oct 16, 2024@18:25:30 Page 2
OCXOCMPI ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Build LIST Function Code) ;10/29/98 12:37
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997
+2 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
+3 ;
+4 QUIT
+5 ;
GETCODE(OCXD0,OCXLIST) ;
+1 ;
+2 if $GET(OCXWARN)
QUIT 1
+3 ;
+4 NEW OCXNDX
+5 ;
+6 SET OCXNDX=0
FOR
SET OCXNDX=$ORDER(OCXLIST(OCXNDX))
if 'OCXNDX
QUIT
Begin DoDot:1
+7 IF OCXLIST(OCXNDX)
Begin DoDot:2
+8 NEW OCXPAR,OCXELE,OCXPC,OCXCODE,OCXVAR
+9 SET OCXPAR=$PIECE(OCXLIST(OCXNDX)," ",3,999)
SET OCXELE=+OCXLIST(OCXNDX)
+10 ;
+11 FOR OCXPC=2:2:$LENGTH(OCXPAR,"|")
Begin DoDot:3
+12 NEW OCXDF
SET OCXDF=+$$DATAFLD($PIECE($PIECE(OCXPAR,"|",OCXPC),"|",1),OCXELE)
+13 IF 'OCXDF
DO WARN^OCXOCMPV("1 Data Field '"_$PIECE($PIECE(OCXPAR,"|",OCXPC),"|",1)_"' not defined for '("_OCXCON_") "_$PIECE($GET(^OCXS(860.6,OCXCON,0)),U,1)_"' data context.",2,OCXD0,$PIECE($TEXT(+1)," ",1))
QUIT
+14 SET $PIECE(OCXPAR,"|",OCXPC)=OCXDF
End DoDot:3
if OCXWARN
QUIT
+15 ;
+16 SET OCXVAR="OCXLX"_(+OCXNDX)
+17 SET OCXLIST(OCXNDX,"CODE",1)="I $$MCE"_(+OCXELE)_" D @@@@"
End DoDot:2
if OCXWARN
QUIT
+18 ;
+19 IF 'OCXLIST(OCXNDX)
Begin DoDot:2
+20 ;
+21 NEW OCXEXP,OCXDTYP,OCXCD
+22 SET OCXEXP=OCXLIST(OCXNDX)
SET OCXDTYP=""
+23 ;
+24 FOR OCXPC=2:2:$LENGTH(OCXEXP,"|")
Begin DoDot:3
+25 NEW OCXELE,OCXDF,OCXDFN,OCXSTR,OCXENDX,OCXNVAL,OCXCON
+26 SET OCXSTR=$PIECE($PIECE(OCXEXP,"|",OCXPC),"|",1)
SET OCXELE=$PIECE(OCXSTR,".",1)
+27 SET OCXDF=$PIECE(OCXSTR,".",2)
SET OCXENDX=+$GET(OCXLIST("B",OCXELE))
+28 if $LENGTH(OCXELE)
SET OCXELE=+$GET(OCXLIST(OCXENDX))
+29 SET OCXCON=+$PIECE($GET(^OCXS(860.3,+OCXELE,0)),U,2)
+30 IF 'OCXELE
DO WARN^OCXOCMPV("Label '"_$PIECE(OCXSTR,".",1)_"' not defined.",2,OCXD0,$PIECE($TEXT(+1)," ",1))
QUIT
+31 SET OCXDFN=+$$DATAFLD(OCXDF,OCXELE)
+32 IF 'OCXDFN
DO WARN^OCXOCMPV("2 Data Field '"_OCXSTR_"' not defined for '"_$PIECE($GET(^OCXS(860.6,+OCXCON,0)),U,1)_"' data context.",2,OCXD0,$PIECE($TEXT(+1)," ",1))
QUIT
+33 SET OCXNVAL="$G(^TMP(""""OCXCHK"""",$J,DFN,"_(+OCXELE)_","_(+OCXDFN)_"))"
+34 SET $PIECE(OCXEXP,"|",OCXPC)=OCXNVAL
+35 IF $LENGTH(OCXDTYP)
IF '(OCXDTYP=$$GETDTYP(+OCXDFN,+OCXCON))
Begin DoDot:4
+36 DO WARN^OCXOCMPV("Invalid Expression, Cannot compare '"_OCXDTYP_"' data with '"_$$GETDTYP(+OCXDFN,+OCXCON)_"' data. ",2,OCXD0,$PIECE($TEXT(+1)," ",1))
QUIT
End DoDot:4
QUIT
+37 IF '$LENGTH(OCXDTYP)
SET OCXDTYP=$$GETDTYP(+OCXDFN,OCXCON)
End DoDot:3
if OCXWARN
QUIT
+38 IF '$LENGTH(OCXDTYP)
DO WARN^OCXOCMPV("Data Type for '"_OCXLIST(OCXNDX,"LABEL")_"' not defined. ",2,OCXD0,$PIECE($TEXT(+1)," ",1))
QUIT
+39 ;
+40 ; GET EXPRESSION CONDITIONAL EVALUATION CODE
+41 ;
+42 SET OCXCD=""
SET OCXWARN=$$GETC^OCXOCMPL(OCXD0,OCXEXP,OCXDTYP,.OCXCD)
+43 SET OCXLIST(OCXNDX,"CODE",1)=OCXCD
End DoDot:2
+44 ;
+45 SET OCXWARN='$DATA(OCXLIST(OCXNDX,"CODE"))
End DoDot:1
if OCXWARN
QUIT
+46 ;
+47 QUIT OCXWARN
+48 ;
DATAFLD(OCXFNAM,OCXEL) ;
+1 ;
+2 NEW OCXDFN,OCXCON,OCXLINK
+3 SET OCXCON=+$PIECE($GET(^OCXS(860.3,+OCXEL,0)),U,2)
SET OCXDFN=$ORDER(^OCXS(860.4,"B",OCXFNAM,0))
+4 if '$LENGTH($GET(OCXFNAM))
QUIT 0
if 'OCXCON
QUIT 0
+5 SET OCXLINK=0
FOR
SET OCXLINK=$ORDER(^OCXS(860.4,OCXDFN,"LINK",OCXLINK))
if 'OCXLINK
QUIT
if (OCXLINK=OCXCON)
QUIT
+6 if OCXLINK
QUIT +OCXDFN
QUIT 0
+7 ;
GETDTYP(OCXDF,OCXCON) ;
+1 ;
+2 NEW OCXLINK,OCXATT
+3 SET OCXDF=+$GET(OCXDF)
SET OCXCON=+$GET(OCXCON)
+4 if 'OCXDF
QUIT ""
if 'OCXCON
QUIT ""
+5 SET OCXLINK=$GET(^OCXS(860.4,+OCXDF,"LINK",OCXCON,"DATAPATH"))
+6 if '$LENGTH(OCXLINK)
QUIT ""
+7 SET OCXLINK=$ORDER(^OCXS(863.3,"B",OCXLINK,0))
if 'OCXLINK
QUIT ""
+8 SET OCXATT=$PIECE($GET(^OCXS(863.3,OCXLINK,0)),U,5)
if 'OCXATT
QUIT ""
+9 QUIT $$GETPARM(34,OCXATT,"DATA TYPE")
+10 ;
GETPARM(FILE,INST,PARM) ;
+1 if '$LENGTH(FILE)
QUIT ""
if '$LENGTH(INST)
QUIT ""
if '$LENGTH(PARM)
QUIT ""
+2 NEW OCXP,OCXP1,OCXI,OCXGL
+3 SET OCXGL="^OCXS"
if (FILE=1)
SET OCXGL="^OCXD"
if (FILE=7)
SET OCXGL="^OCXD"
if (FILE=10)
SET OCXGL="^OCXD"
SET FILE=FILE/10+860
+4 if '$DATA(@OCXGL@(+FILE,0))
QUIT ""
+5 IF (PARM=+PARM)
IF $DATA(^OCXS(863.8,PARM,0))
SET OCXP=PARM
+6 IF '$TEST
SET OCXP=$ORDER(^OCXS(863.8,"B",PARM,0))
+7 if 'OCXP
QUIT ""
+8 IF (INST=+INST)
IF $DATA(@OCXGL@(FILE,INST,0))
SET OCXI=INST
+9 IF '$TEST
SET OCXI=$ORDER(@OCXGL@(FILE,"B",INST,0))
+10 if 'OCXI
QUIT ""
SET OCXP1=$ORDER(@OCXGL@(FILE,OCXI,"PAR","B",OCXP,0))
if 'OCXP1
QUIT ""
+11 QUIT $GET(@OCXGL@(FILE,OCXI,"PAR",OCXP1,"VAL"))
+12 ;
LAST(ROOT,ELEM,INDEX,PARAM,CD) QUIT $$LAST^OCXOCMPJ(ROOT,ELEM,INDEX,PARAM,.CD)
FIRST(ROOT,ELEM,INDEX,PARAM,CD) QUIT $$FIRST^OCXOCMPJ(ROOT,ELEM,INDEX,PARAM,.CD)
RANGE(ROOT,ELEM,INDEX,PARAM,CD) QUIT $$RANGE^OCXOCMPK(ROOT,ELEM,INDEX,PARAM,.CD)
ANY(ROOT,ELEM,INDEX,PARAM,CD) QUIT $$ANY^OCXOCMPK(ROOT,ELEM,INDEX,PARAM,.CD)
+1 ;
