- 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)
- ;
- 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 ;
