- OCXOCMPQ ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Sort Code Segments cont...) ;3/21/01 10:17
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,105**;Dec 17,1997
- ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
- ;
- ;
- TIME(T,OCXD0,OCXD1) ;
- ;
- N TIME
- S TIME=""
- I (T["|") D
- .N DAY,OPER,OFFS
- .I ($E(T,1)="|") S DAY=$P(T,"|",2) I $L(DAY) S DAY=$$DFLKUP(DAY) I DAY S DAY="|"_$P(T,"|",2)_"|"
- .E Q
- .S OPER=$P($P(T,"|",3)," ",2) I '(OPER="+"),'(OPER="-") Q
- .S OFFS=$P($P(T,"|",3)," ",3) I '(OFFS?1.N1"H"),'(OFFS?1.N1"D"),'(OFFS?1.N1"W"),'(OFFS?1.N1"M") Q
- .S TIME=$$XLATE(DAY,OCXD0,OCXD1)_","""_OPER_""","""_OFFS_""""
- I '(T["|") D
- .N DAY,OPER,OFFS
- .S DAY=$P(T," ",1) I '(DAY="TODAY"),'(DAY="NOW") Q
- .S OPER=$P(T," ",2) I '(OPER="+"),'(OPER="-") Q
- .S OFFS=$P(T," ",3) I '(OFFS?1.N1"H"),'(OFFS?1.N1"D"),'(OFFS?1.N1"W"),'(OFFS?1.N1"M") Q
- .S TIME=""""_$E(DAY,1)_""","""_OPER_""","""_OFFS_""""
- Q TIME
- ;
- DFLKUP(X) ;
- N XL,Y
- S Y=0 F XL=$L(X):-1:1 Q:Y S Y=0 F S Y=$O(^OCXS(860.4,"B",$E(X,1,XL),Y)) Q:'Y Q:($P($G(^OCXS(860.4,Y,0)),U,1)=X)
- Q Y
- ;
- XLATE(MSG,D0,D1,OCXDTCD) ;
- ;
- N PIEC,ERROR S ERROR=0
- S OCXDTCD=+$G(OCXDTCD)
- I (MSG["|") S:('$L(MSG,"|")#2) MSG=MSG_"|" F PIEC=2:2:$L(MSG,"|") D Q:ERROR
- .N FLD,ELIST,LABEL,D2,DFLD,TEMP
- .S FLD=$P(MSG,"|",PIEC),(DFLD,ELIST)=0,GETDATA=""
- .I (FLD[".") D I 1
- ..S LABEL=$P(FLD,".",1),DFLD=$P(FLD,".",2),D2=0
- ..I $L(LABEL) S D2=$O(^OCXS(860.2,D0,"C","B",LABEL,0)) S:'D2 D2=$O(^OCXS(860.2,D0,"C","C",LABEL,0))
- ..S:D2 ELIST=+$P($G(^OCXS(860.2,D0,"C",D2,0)),U,2)
- ..S:$L(DFLD) DFLD=$$GETDF(DFLD)
- .E D
- ..S ELIST="" S:$L(FLD) DFLD=$$GETDF(FLD) Q:'DFLD
- ..S D2=0 F S D2=$O(^TMP("OCXCMP",$J,"RULE",D0,D1,D2)) Q:'D2 S:$L(ELIST) ELIST=ELIST_U S ELIST=ELIST_D2
- .;
- .S ERROR=0,GETDATA="" I $L(ELIST) D
- ..N NDX
- ..S:'(ELIST[U) ELIST=ELIST_U
- ..;
- ..I $L(ELIST),DFLD,($$GETDTYP(+DFLD)="DATE/TIME") S GETDATA="$$INT2DT($$GETDATA(DFN,"""_ELIST_""","_DFLD_"),0)"
- ..E I $L(ELIST),DFLD,($$GETDTYP(+DFLD)="BOOLEAN") S GETDATA="$S($$GETDATA(DFN,"""_ELIST_""","_DFLD_"):""TRUE"",1:""FALSE"")"
- ..E I $L(ELIST),DFLD S GETDATA="$$GETDATA(DFN,"""_ELIST_""","_DFLD_")"
- .I '$L(GETDATA) S ERROR=1 Q
- .S MSG=$P(MSG,"|",1,PIEC-1)_"|"_GETDATA_"|"_$P(MSG,"|",PIEC+1,99)
- ;
- I 'OCXDTCD D
- .S:'($E(MSG,1)="|") MSG=""""_MSG
- .S:($E(MSG,1)="|") MSG=$E(MSG,2,$L(MSG))
- .S:'($E(MSG,$L(MSG))="|") MSG=MSG_""""
- .S:($E(MSG,$L(MSG))="|") MSG=$E(MSG,1,$L(MSG)-1)
- .F Q:'(MSG["||") S MSG=$P(MSG,"||",1)_"_"_$P(MSG,"||",2,999)
- .F Q:'(MSG["|") D
- ..N MSG1,MSG2 S MSG1=$P(MSG,"|",1),MSG2=$P(MSG,"|",2)
- ..I ($E(MSG1,$L(MSG1))=")") S MSG=MSG1_"_"""_$P(MSG,"|",2,999)
- ..I ($E(MSG2,1)="$") S MSG=$P(MSG,"|",1)_"""_"_$P(MSG,"|",2,999)
- ;
- I OCXDTCD S MSG=$TR(MSG,"|","")
- ;
- Q MSG
- K D0,D1
- ;
- GETDTYP(OCXDF) ;
- ;
- N OCXLINK,OCXATT,OCXCON,OCXDTYP
- Q:'$G(OCXDF) ""
- S OCXDTYP="",OCXCON=0 F S OCXCON=$O(^OCXS(860.4,+OCXDF,"LINK",OCXCON)) Q:'OCXCON D Q:$L(OCXDTYP)
- .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 ""
- .S OCXDTYP=$$GETPARM(34,OCXATT,"DATA TYPE")
- Q OCXDTYP
- ;
- 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"))
- ;
- GETDF(FNAM) ;
- ;
- S FNUM=$O(^OCXS(860.4,"C",FNAM,0))
- I 'FNUM S FNUM=0 F S FNUM=$O(^OCXS(860.4,"B",$E(FNAM,1,30),0)) Q:'FNUM Q:($P($G(^OCXS(860.4,FNUM,0)),U,1)=FNAM)
- Q +FNUM
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOCXOCMPQ 3972 printed Mar 13, 2025@21:29:59 Page 2
- OCXOCMPQ ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Sort Code Segments cont...) ;3/21/01 10:17
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,105**;Dec 17,1997
- +2 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
- +3 ;
- +4 ;
- TIME(T,OCXD0,OCXD1) ;
- +1 ;
- +2 NEW TIME
- +3 SET TIME=""
- +4 IF (T["|")
- Begin DoDot:1
- +5 NEW DAY,OPER,OFFS
- +6 IF ($EXTRACT(T,1)="|")
- SET DAY=$PIECE(T,"|",2)
- IF $LENGTH(DAY)
- SET DAY=$$DFLKUP(DAY)
- IF DAY
- SET DAY="|"_$PIECE(T,"|",2)_"|"
- +7 IF '$TEST
- QUIT
- +8 SET OPER=$PIECE($PIECE(T,"|",3)," ",2)
- IF '(OPER="+")
- IF '(OPER="-")
- QUIT
- +9 SET OFFS=$PIECE($PIECE(T,"|",3)," ",3)
- IF '(OFFS?1.N1"H")
- IF '(OFFS?1.N1"D")
- IF '(OFFS?1.N1"W")
- IF '(OFFS?1.N1"M")
- QUIT
- +10 SET TIME=$$XLATE(DAY,OCXD0,OCXD1)_","""_OPER_""","""_OFFS_""""
- End DoDot:1
- +11 IF '(T["|")
- Begin DoDot:1
- +12 NEW DAY,OPER,OFFS
- +13 SET DAY=$PIECE(T," ",1)
- IF '(DAY="TODAY")
- IF '(DAY="NOW")
- QUIT
- +14 SET OPER=$PIECE(T," ",2)
- IF '(OPER="+")
- IF '(OPER="-")
- QUIT
- +15 SET OFFS=$PIECE(T," ",3)
- IF '(OFFS?1.N1"H")
- IF '(OFFS?1.N1"D")
- IF '(OFFS?1.N1"W")
- IF '(OFFS?1.N1"M")
- QUIT
- +16 SET TIME=""""_$EXTRACT(DAY,1)_""","""_OPER_""","""_OFFS_""""
- End DoDot:1
- +17 QUIT TIME
- +18 ;
- DFLKUP(X) ;
- +1 NEW XL,Y
- +2 SET Y=0
- FOR XL=$LENGTH(X):-1:1
- if Y
- QUIT
- SET Y=0
- FOR
- SET Y=$ORDER(^OCXS(860.4,"B",$EXTRACT(X,1,XL),Y))
- if 'Y
- QUIT
- if ($PIECE($GET(^OCXS(860.4,Y,0)),U,1)=X)
- QUIT
- +3 QUIT Y
- +4 ;
- XLATE(MSG,D0,D1,OCXDTCD) ;
- +1 ;
- +2 NEW PIEC,ERROR
- SET ERROR=0
- +3 SET OCXDTCD=+$GET(OCXDTCD)
- +4 IF (MSG["|")
- if ('$LENGTH(MSG,"|")#2)
- SET MSG=MSG_"|"
- FOR PIEC=2:2:$LENGTH(MSG,"|")
- Begin DoDot:1
- +5 NEW FLD,ELIST,LABEL,D2,DFLD,TEMP
- +6 SET FLD=$PIECE(MSG,"|",PIEC)
- SET (DFLD,ELIST)=0
- SET GETDATA=""
- +7 IF (FLD[".")
- Begin DoDot:2
- +8 SET LABEL=$PIECE(FLD,".",1)
- SET DFLD=$PIECE(FLD,".",2)
- SET D2=0
- +9 IF $LENGTH(LABEL)
- SET D2=$ORDER(^OCXS(860.2,D0,"C","B",LABEL,0))
- if 'D2
- SET D2=$ORDER(^OCXS(860.2,D0,"C","C",LABEL,0))
- +10 if D2
- SET ELIST=+$PIECE($GET(^OCXS(860.2,D0,"C",D2,0)),U,2)
- +11 if $LENGTH(DFLD)
- SET DFLD=$$GETDF(DFLD)
- End DoDot:2
- IF 1
- +12 IF '$TEST
- Begin DoDot:2
- +13 SET ELIST=""
- if $LENGTH(FLD)
- SET DFLD=$$GETDF(FLD)
- if 'DFLD
- QUIT
- +14 SET D2=0
- FOR
- SET D2=$ORDER(^TMP("OCXCMP",$JOB,"RULE",D0,D1,D2))
- if 'D2
- QUIT
- if $LENGTH(ELIST)
- SET ELIST=ELIST_U
- SET ELIST=ELIST_D2
- End DoDot:2
- +15 ;
- +16 SET ERROR=0
- SET GETDATA=""
- IF $LENGTH(ELIST)
- Begin DoDot:2
- +17 NEW NDX
- +18 if '(ELIST[U)
- SET ELIST=ELIST_U
- +19 ;
- +20 IF $LENGTH(ELIST)
- IF DFLD
- IF ($$GETDTYP(+DFLD)="DATE/TIME")
- SET GETDATA="$$INT2DT($$GETDATA(DFN,"""_ELIST_""","_DFLD_"),0)"
- +21 IF '$TEST
- IF $LENGTH(ELIST)
- IF DFLD
- IF ($$GETDTYP(+DFLD)="BOOLEAN")
- SET GETDATA="$S($$GETDATA(DFN,"""_ELIST_""","_DFLD_"):""TRUE"",1:""FALSE"")"
- +22 IF '$TEST
- IF $LENGTH(ELIST)
- IF DFLD
- SET GETDATA="$$GETDATA(DFN,"""_ELIST_""","_DFLD_")"
- End DoDot:2
- +23 IF '$LENGTH(GETDATA)
- SET ERROR=1
- QUIT
- +24 SET MSG=$PIECE(MSG,"|",1,PIEC-1)_"|"_GETDATA_"|"_$PIECE(MSG,"|",PIEC+1,99)
- End DoDot:1
- if ERROR
- QUIT
- +25 ;
- +26 IF 'OCXDTCD
- Begin DoDot:1
- +27 if '($EXTRACT(MSG,1)="|")
- SET MSG=""""_MSG
- +28 if ($EXTRACT(MSG,1)="|")
- SET MSG=$EXTRACT(MSG,2,$LENGTH(MSG))
- +29 if '($EXTRACT(MSG,$LENGTH(MSG))="|")
- SET MSG=MSG_""""
- +30 if ($EXTRACT(MSG,$LENGTH(MSG))="|")
- SET MSG=$EXTRACT(MSG,1,$LENGTH(MSG)-1)
- +31 FOR
- if '(MSG["||")
- QUIT
- SET MSG=$PIECE(MSG,"||",1)_"_"_$PIECE(MSG,"||",2,999)
- +32 FOR
- if '(MSG["|")
- QUIT
- Begin DoDot:2
- +33 NEW MSG1,MSG2
- SET MSG1=$PIECE(MSG,"|",1)
- SET MSG2=$PIECE(MSG,"|",2)
- +34 IF ($EXTRACT(MSG1,$LENGTH(MSG1))=")")
- SET MSG=MSG1_"_"""_$PIECE(MSG,"|",2,999)
- +35 IF ($EXTRACT(MSG2,1)="$")
- SET MSG=$PIECE(MSG,"|",1)_"""_"_$PIECE(MSG,"|",2,999)
- End DoDot:2
- End DoDot:1
- +36 ;
- +37 IF OCXDTCD
- SET MSG=$TRANSLATE(MSG,"|","")
- +38 ;
- +39 QUIT MSG
- +40 KILL D0,D1
- +41 ;
- GETDTYP(OCXDF) ;
- +1 ;
- +2 NEW OCXLINK,OCXATT,OCXCON,OCXDTYP
- +3 if '$GET(OCXDF)
- QUIT ""
- +4 SET OCXDTYP=""
- SET OCXCON=0
- FOR
- SET OCXCON=$ORDER(^OCXS(860.4,+OCXDF,"LINK",OCXCON))
- if 'OCXCON
- QUIT
- Begin DoDot:1
- +5 SET OCXLINK=$GET(^OCXS(860.4,+OCXDF,"LINK",OCXCON,"DATAPATH"))
- if '$LENGTH(OCXLINK)
- QUIT ""
- +6 SET OCXLINK=$ORDER(^OCXS(863.3,"B",OCXLINK,0))
- if 'OCXLINK
- QUIT ""
- +7 SET OCXATT=$PIECE($GET(^OCXS(863.3,OCXLINK,0)),U,5)
- if 'OCXATT
- QUIT ""
- +8 SET OCXDTYP=$$GETPARM(34,OCXATT,"DATA TYPE")
- End DoDot:1
- if $LENGTH(OCXDTYP)
- QUIT
- +9 QUIT OCXDTYP
- +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 ;
- GETDF(FNAM) ;
- +1 ;
- +2 SET FNUM=$ORDER(^OCXS(860.4,"C",FNAM,0))
- +3 IF 'FNUM
- SET FNUM=0
- FOR
- SET FNUM=$ORDER(^OCXS(860.4,"B",$EXTRACT(FNAM,1,30),0))
- if 'FNUM
- QUIT
- if ($PIECE($GET(^OCXS(860.4,FNUM,0)),U,1)=FNAM)
- QUIT
- +4 QUIT +FNUM
