Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: OCXOCMPS

OCXOCMPS.m

Go to the documentation of this file. 
  1. OCXOCMPS ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Screen Code Library) ;8/16/99  09:03
  1.  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997
  1.  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
  1.  ;
  1. EN ;
  1.  ;
  1.  Q
  1.  ;
  1. OPSCR() ;
  1.  ;
  1.  N OCXDT,OCXOPDT
  1.  S OCXOPDT=$P($G(^OCXS(864.1,+$P(^(0),U,2),0)),U,1)
  1.  S OCXDT=$$DTYP(+$G(^OCXS(860.3,+$G(DA(1)),"COND",+$G(DA),"DFLD1")))
  1.  Q:'(OCXDT=OCXOPDT) 0 Q ''$D(^OCXS(863.9,+Y,"PAR","B","OCXO GENERATE CODE FUNCTION"))
  1.  ;
  1. SCFLD(OCXNODE,OCXD0) ;
  1.  ;
  1.  ; This subroutine is called from the input transform of
  1.  ; 'Data Field 1', 'Data Field 2', and 'Data Field 3' of the
  1.  ; Conditional Expression Sub-Field of the Order Check Element
  1.  ; file. The naked pointer should therefore be pointing to the
  1.  ; 'zero' node of the record being processed.
  1.  ;
  1.  N CONTXT,LINKS,D0
  1.  M LINKS=^("LINK")
  1.  S CONTXT=$P($G(^OCXS(860.3,OCXD0,0)),U,2)
  1.  I $D(LINKS(+CONTXT)) Q 1
  1.  S CONTXT=$O(^OCXS(860.6,"B","DATABASE LOOKUP",0)) Q:'CONTXT 0
  1.  Q ''$D(LINKS(+CONTXT))
  1.  ;
  1. SOURCE(OCXNODE,D0,D1) ;
  1.  ;
  1.  Q ($P(OCXNODE,U,2)=(+$G(^OCXS(860.4,D0,"LINK",D1,0))))
  1.  ;
  1. DTYP(DFLD) ;
  1.  Q:'DFLD "A"
  1.  N OCXLINK,OCXATT,OCXDTN,OCXDTYP,OCXX,OCXCON
  1.  S OCXCON=$O(^OCXS(860.4,+DFLD,"LINK",0)) Q:'OCXCON "AA"
  1.  S OCXLINK=$G(^OCXS(860.4,+DFLD,"LINK",OCXCON,"DATAPATH")) Q:'$L(OCXLINK) "B"
  1.  S OCXLINK=$O(^OCXS(863.3,"B",OCXLINK,0)) Q:'OCXLINK "C"
  1.  S OCXATT=$P($G(^OCXS(863.3,+OCXLINK,0)),U,5) Q:'OCXATT "D"
  1.  S OCXDTN=$O(^OCXS(863.8,"B","DATA TYPE",0)) Q:'OCXDTN "E"
  1.  S OCXX=0 F  S OCXX=$O(^OCXS(863.4,OCXATT,"PAR",OCXX)) Q:'OCXX  Q:($P(^OCXS(863.4,OCXATT,"PAR",OCXX,0),U,1)=OCXDTN)
  1.  Q:'OCXX "F" Q $G(^OCXS(863.4,OCXATT,"PAR",OCXX,"VAL"))
  1.  ;
  1. LABEL ;
  1.  N OCXER,OCXX,OCXY,OCXSUB
  1.  S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1.  S OCXX=X,OCXER=0
  1.  I ($L(X)>30)!($L(X)<1) W !,"   ",$L(OCXX)," characters, Label TOO long... " S OCXER=OCXER+1
  1.  I (X["(") W !,"  Illegal punctuation -> '(' " S OCXER=OCXER+1
  1.  I (X[")") W !,"  Illegal punctuation -> ')' " S OCXER=OCXER+1
  1.  S OCXY=$O(^OCXS(860.2,+$G(DA(1)),"C","C",X,0))
  1.  I OCXY,'(OCXY=DA) W !,"  This label already used by another element",!,"   -> ",$P($G(^OCXS(860.3,+$G(^OCXS(860.2,DA(1),"C",OCXY,0)),0)),U,1) S OCXER=OCXER+1
  1.  S OCXY=$O(^OCXS(864.1,"B","BOOLEAN",0))
  1.  I OCXY F OCXSUB="B","AKA" D
  1.  .N OCXNAM S OCXNAM="" F  S OCXNAM=$O(^OCXS(863.9,OCXSUB,OCXNAM)) Q:'$L(OCXNAM)  D
  1.  ..S OCXX=0 F  S OCXX=$O(^OCXS(863.9,OCXSUB,OCXNAM,OCXX)) Q:'OCXX  D
  1.  ...N OCXDTYP S OCXDTYP=$P($G(^OCXS(863.9,OCXX,0)),U,2) Q:'(OCXDTYP=OCXY)
  1.  ...I ((" "_X_" ")[(" "_OCXNAM_" ")) W !,"  Illegal Reserved word -> '",OCXNAM,"'" S OCXER=OCXER+1
  1.  I (" "_X_" "[(" IF ")) W !,"  Illegal Reserved word -> 'IF'" S OCXER=OCXER+1
  1.  ;
  1.  I OCXER K X
  1.  Q
  1.  ;