ORDD100 ; slc/dcm - DD entries for file 100 ;06/18/2004 10:00
;;3.0;ORDER ENTRY/RESULTS REPORTING;**27,157,255**;Dec 17, 1997
SETALL(ORIFN) ; -- set "AC" xref for all actions
N ORYD,ORVP,ORSTOP,OR3,ORSTS,ORLOG,ORACT,ORACT0,ORCACT D ORYD
S ORVP=$P($G(^OR(100,ORIFN,0)),U,2),ORSTOP=$P($G(^(0)),U,9) Q:'ORVP
S OR3=$G(^OR(100,ORIFN,3)),ORSTS=$P(OR3,U,3),ORCACT=$P(OR3,U,7)
S ORACT=0 F S ORACT=$O(^OR(100,ORIFN,8,ORACT)) Q:ORACT'>0 D SET1
Q
SET(ORIFN,ORACT) ; -- set "AC" xref by action
N ORYD,ORVP,ORSTOP,OR3,ORSTS,ORLOG,ORACT0,ORCACT D ORYD
S ORVP=$P($G(^OR(100,ORIFN,0)),U,2),ORSTOP=$P($G(^(0)),U,9) Q:'ORVP
S OR3=$G(^OR(100,ORIFN,3)),ORSTS=$P(OR3,U,3),ORCACT=$P(OR3,U,7)
SET1 S ORACT0=$G(^OR(100,ORIFN,8,ORACT,0)),ORLOG=$P(ORACT0,U)
K ^OR(100,"AC",ORVP,9999999-ORLOG,ORIFN,ORACT) ; reset
I ORACT'=ORCACT D Q ; not Current action
. I $P(ORACT0,U,15)=11 S ^OR(100,"AC",ORVP,9999999-ORLOG,ORIFN,ORACT)="" Q
. I ORYD,$P(ORACT0,U,15)=13,ORLOG'<ORYD S ^OR(100,"AC",ORVP,9999999-ORLOG,ORIFN,ORACT)=""
. I $P(ORACT0,U,15)="",ORACT=1,$P($G(^OR(100,ORIFN,8,ORCACT,0)),U,2)="RL",$S('ORYD:1,$P($G(^(0)),U,16)<ORYD:1,1:0) S $P(^OR(100,ORIFN,3),U,7)=1,^OR(100,"AC",ORVP,9999999-ORLOG,ORIFN,1)="" ;Replace RL w/NW
I ORSTS,ORSTS'=1,ORSTS'=2,ORSTS'=7,ORSTS'=10,ORSTS'=12,ORSTS'=13,ORSTS'=14,ORSTS'=99 S ^OR(100,"AC",ORVP,9999999-ORLOG,ORIFN,ORACT)=""
I ORYD,(ORSTS=1!(ORSTS=2)!(ORSTS=7)!(ORSTS=13)),ORSTOP'<ORYD S ^OR(100,"AC",ORVP,9999999-ORLOG,ORIFN,ORACT)=""
Q
KILALL(ORIFN) ; -- kill "AC" xref for all actions
N ORVP,ORACT,ORLOG
S ORVP=$P($G(^OR(100,ORIFN,0)),U,2),ORACT=0 Q:'ORVP
F S ORACT=$O(^OR(100,ORIFN,8,ORACT)) Q:ORACT'>0 S ORLOG=$P(^(ORACT,0),U) K:ORLOG ^OR(100,"AC",ORVP,9999999-ORLOG,ORIFN,ORACT)
Q
KIL(ORIFN,ORACT) ; -- kill "AC" xref
N ORVP,ORLOG
S ORVP=$P($G(^OR(100,ORIFN,0)),U,2),ORLOG=$P($G(^(8,ORACT,0)),U) Q:'ORVP
K:ORLOG ^OR(100,"AC",ORVP,9999999-ORLOG,ORIFN,ORACT)
Q
;
ORYD ; -- Return Current Orders context hours in ORYD
N X,X1,X2,X3,%,%H
S ORYD=$$GET^XPAR("SYS","ORPF ACTIVE ORDERS CONTEXT HRS",1,"I")
YD1 I ORYD S X=$H,X=+X*24+($P(X,",",2)/3600),X2=ORYD,X1=X-X2,X3=X1#24,X1=X1\24,X2=$J(X3*3600,0,0),%H=X1_","_X2 D YMD^%DTC S ORYD=+(X_%)
Q
;
SS ; -- set "AD" xref
N ORSTRT S ORSTRT=$P($G(^OR(100,DA,0)),U,8)
I ORSTRT,ORSTRT>$$NOW^XLFDT S ^OR(100,"AD",ORSTRT,DA)=""
Q
SK ; -- kill "AD" xref
N ORSTRT S ORSTRT=$P($G(^OR(100,DA,0)),U,8)
I ORSTRT K ^OR(100,"AD",ORSTRT,DA)
Q
;
WS ; -- set "AW" xref
N ORVP,ORDG,ORSTRT,X,X0
S X0=$G(^OR(100,DA,0)),ORVP=$P(X0,U,2),ORDG=$P(X0,U,11)
S ORSTRT=$P(X0,U,8),X=$S(ORSTRT:ORSTRT,1:9999999)
I ORVP,ORDG S ^OR(100,"AW",ORVP,ORDG,X,DA)=""
Q
WK ; -- kill "AW" xref
N ORVP,ORDG,ORSTRT,X,X0
S X0=$G(^OR(100,DA,0)),ORVP=$P(X0,U,2),ORDG=$P(X0,U,11)
S ORSTRT=$P(X0,U,8),X=$S(ORSTRT:ORSTRT,1:9999999)
I ORVP,ORDG K ^OR(100,"AW",ORVP,ORDG,X,DA)
Q
;
S1(ORIFN,ORACT,ORVP,ORLOG) ; -- set "AS" xref
N OR0 S OR0=$G(^OR(100,ORIFN,8,ORACT,0)) Q:$P(OR0,U,4)'=2 ;unsigned
S:'$G(ORLOG) ORLOG=$P(OR0,U) S:'$G(ORVP) ORVP=$P(^OR(100,ORIFN,0),U,2)
I ORVP,ORLOG S ^OR(100,"AS",ORVP,9999999-ORLOG,ORIFN,ORACT)=""
Q
S2(ORIFN,ORACT,ORVP,ORLOG) ; -- kill "AS" xref
N OR0 S:'$G(ORVP) ORVP=$P(^OR(100,ORIFN,0),U,2)
S:'$G(ORLOG) ORLOG=$P($G(^OR(100,ORIFN,8,ORACT,0)),U)
I ORLOG,ORVP K ^OR(100,"AS",ORVP,9999999-ORLOG,ORIFN,ORACT)
Q
;
RS(ORIFN,ORACT,ORVP,ORRDT) ; -- set "AR" xref
N OR80
Q:'$G(ORIFN) Q:'$G(ORACT)
S:'$G(ORVP) ORVP=$P($G(^OR(100,ORIFN,0)),U,2)
S OR80=$G(^OR(100,ORIFN,8,ORACT,0))
S:'$G(ORRDT) ORRDT=$P(OR80,U,16)
I ORVP,ORRDT S ^OR(100,"AR",ORVP,(9999999-ORRDT),ORIFN,ORACT)=""
I ORVP'["DPT"!ORRDT="" Q
I $P(OR80,U,2)="NW" D PXRMADD(ORIFN,ORVP,ORRDT)
Q
;
PXRMADD(ORIFN,ORVP,ORRDT) ; -- set "PXRM" xref
N DAES,OI,OR0,START,X
S DAES(1)=ORIFN
S X(1)=ORVP
S OR0=^OR(100,ORIFN,0)
S START=$P(OR0,U,8)
S X(3)=$S(START="":ORRDT,1:START)
S X(4)=$P(OR0,U,9)
S OI=0 F S OI=$O(^OR(100,ORIFN,.1,OI)) Q:OI'>0 D
. S X(2)=+$G(^(OI,0)),DAES=OI
. D SOR^ORPXRM(.X,.DAES)
Q
;
RK(ORIFN,ORACT,ORVP,ORRDT) ; -- kill "AR" xref
N OR80
Q:'$G(ORIFN) Q:'$G(ORACT)
S:'$G(ORVP) ORVP=$P($G(^OR(100,ORIFN,0)),U,2)
S OR80=$G(^OR(100,ORIFN,8,ORACT,0))
S:'$G(ORRDT) ORRDT=$P(OR80,U,16)
I ORVP,ORRDT K ^OR(100,"AR",ORVP,(9999999-ORRDT),ORIFN,ORACT)
I ORVP'["DPT"!ORRDT="" Q
I $P(OR80,U,2)="NW" D PXRMKILL(ORIFN,ORVP,ORRDT)
Q
;
PXRMKILL(ORIFN,ORVP,ORRDT) ; -- kill "PXRM" xref
N DAES,OI,OR0,START,X
S DAES(1)=ORIFN
S X(1)=ORVP
S OR0=^OR(100,ORIFN,0)
S START=$P(OR0,U,8)
S X(3)=$S(START="":ORRDT,1:START)
S X(4)=$P(OR0,U,9)
S OI=0 F S OI=$O(^OR(100,ORIFN,.1,OI)) Q:OI'>0 D
. S X(2)=+$G(^(OI,0)),DAES=OI
. D KOR^ORPXRM(.X,.DAES)
Q
;
VS ; -- set "AEVNT" xref
N ORVP,OREVNT
S ORVP=$P($G(^OR(100,DA,0)),U,2),OREVNT=$P($G(^(0)),U,17)
I ORVP,$L(OREVNT) S ^OR(100,"AEVNT",ORVP,OREVNT,DA)=""
Q
;
VK ; -- kill "AEVNT" xref
N ORVP,OREVNT
S ORVP=$P($G(^OR(100,DA,0)),U,2),OREVNT=$P($G(^(0)),U,17)
I ORVP,$L(OREVNT) K ^OR(100,"AEVNT",ORVP,OREVNT,DA)
Q
;
UP(X) ; -- Convert X to upper case
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORDD100 5194 printed Jan 18, 2025@03:30:57 Page 2
ORDD100 ; slc/dcm - DD entries for file 100 ;06/18/2004 10:00
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**27,157,255**;Dec 17, 1997
SETALL(ORIFN) ; -- set "AC" xref for all actions
+1 NEW ORYD,ORVP,ORSTOP,OR3,ORSTS,ORLOG,ORACT,ORACT0,ORCACT
DO ORYD
+2 SET ORVP=$PIECE($GET(^OR(100,ORIFN,0)),U,2)
SET ORSTOP=$PIECE($GET(^(0)),U,9)
if 'ORVP
QUIT
+3 SET OR3=$GET(^OR(100,ORIFN,3))
SET ORSTS=$PIECE(OR3,U,3)
SET ORCACT=$PIECE(OR3,U,7)
+4 SET ORACT=0
FOR
SET ORACT=$ORDER(^OR(100,ORIFN,8,ORACT))
if ORACT'>0
QUIT
DO SET1
+5 QUIT
SET(ORIFN,ORACT) ; -- set "AC" xref by action
+1 NEW ORYD,ORVP,ORSTOP,OR3,ORSTS,ORLOG,ORACT0,ORCACT
DO ORYD
+2 SET ORVP=$PIECE($GET(^OR(100,ORIFN,0)),U,2)
SET ORSTOP=$PIECE($GET(^(0)),U,9)
if 'ORVP
QUIT
+3 SET OR3=$GET(^OR(100,ORIFN,3))
SET ORSTS=$PIECE(OR3,U,3)
SET ORCACT=$PIECE(OR3,U,7)
SET1 SET ORACT0=$GET(^OR(100,ORIFN,8,ORACT,0))
SET ORLOG=$PIECE(ORACT0,U)
+1 ; reset
KILL ^OR(100,"AC",ORVP,9999999-ORLOG,ORIFN,ORACT)
+2 ; not Current action
IF ORACT'=ORCACT
Begin DoDot:1
+3 IF $PIECE(ORACT0,U,15)=11
SET ^OR(100,"AC",ORVP,9999999-ORLOG,ORIFN,ORACT)=""
QUIT
+4 IF ORYD
IF $PIECE(ORACT0,U,15)=13
IF ORLOG'<ORYD
SET ^OR(100,"AC",ORVP,9999999-ORLOG,ORIFN,ORACT)=""
+5 ;Replace RL w/NW
IF $PIECE(ORACT0,U,15)=""
IF ORACT=1
IF $PIECE($GET(^OR(100,ORIFN,8,ORCACT,0)),U,2)="RL"
IF $SELECT('ORYD:1,$PIECE($GET(^(0)),U,16)<ORYD:1,1:0)
SET $PIECE(^OR(100,ORIFN,3),U,7)=1
SET ^OR(100,"AC",ORVP,9999999-ORLOG,ORIFN,1)=""
End DoDot:1
QUIT
+6 IF ORSTS
IF ORSTS'=1
IF ORSTS'=2
IF ORSTS'=7
IF ORSTS'=10
IF ORSTS'=12
IF ORSTS'=13
IF ORSTS'=14
IF ORSTS'=99
SET ^OR(100,"AC",ORVP,9999999-ORLOG,ORIFN,ORACT)=""
+7 IF ORYD
IF (ORSTS=1!(ORSTS=2)!(ORSTS=7)!(ORSTS=13))
IF ORSTOP'<ORYD
SET ^OR(100,"AC",ORVP,9999999-ORLOG,ORIFN,ORACT)=""
+8 QUIT
KILALL(ORIFN) ; -- kill "AC" xref for all actions
+1 NEW ORVP,ORACT,ORLOG
+2 SET ORVP=$PIECE($GET(^OR(100,ORIFN,0)),U,2)
SET ORACT=0
if 'ORVP
QUIT
+3 FOR
SET ORACT=$ORDER(^OR(100,ORIFN,8,ORACT))
if ORACT'>0
QUIT
SET ORLOG=$PIECE(^(ORACT,0),U)
if ORLOG
KILL ^OR(100,"AC",ORVP,9999999-ORLOG,ORIFN,ORACT)
+4 QUIT
KIL(ORIFN,ORACT) ; -- kill "AC" xref
+1 NEW ORVP,ORLOG
+2 SET ORVP=$PIECE($GET(^OR(100,ORIFN,0)),U,2)
SET ORLOG=$PIECE($GET(^(8,ORACT,0)),U)
if 'ORVP
QUIT
+3 if ORLOG
KILL ^OR(100,"AC",ORVP,9999999-ORLOG,ORIFN,ORACT)
+4 QUIT
+5 ;
ORYD ; -- Return Current Orders context hours in ORYD
+1 NEW X,X1,X2,X3,%,%H
+2 SET ORYD=$$GET^XPAR("SYS","ORPF ACTIVE ORDERS CONTEXT HRS",1,"I")
YD1 IF ORYD
SET X=$HOROLOG
SET X=+X*24+($PIECE(X,",",2)/3600)
SET X2=ORYD
SET X1=X-X2
SET X3=X1#24
SET X1=X1\24
SET X2=$JUSTIFY(X3*3600,0,0)
SET %H=X1_","_X2
DO YMD^%DTC
SET ORYD=+(X_%)
+1 QUIT
+2 ;
SS ; -- set "AD" xref
+1 NEW ORSTRT
SET ORSTRT=$PIECE($GET(^OR(100,DA,0)),U,8)
+2 IF ORSTRT
IF ORSTRT>$$NOW^XLFDT
SET ^OR(100,"AD",ORSTRT,DA)=""
+3 QUIT
SK ; -- kill "AD" xref
+1 NEW ORSTRT
SET ORSTRT=$PIECE($GET(^OR(100,DA,0)),U,8)
+2 IF ORSTRT
KILL ^OR(100,"AD",ORSTRT,DA)
+3 QUIT
+4 ;
WS ; -- set "AW" xref
+1 NEW ORVP,ORDG,ORSTRT,X,X0
+2 SET X0=$GET(^OR(100,DA,0))
SET ORVP=$PIECE(X0,U,2)
SET ORDG=$PIECE(X0,U,11)
+3 SET ORSTRT=$PIECE(X0,U,8)
SET X=$SELECT(ORSTRT:ORSTRT,1:9999999)
+4 IF ORVP
IF ORDG
SET ^OR(100,"AW",ORVP,ORDG,X,DA)=""
+5 QUIT
WK ; -- kill "AW" xref
+1 NEW ORVP,ORDG,ORSTRT,X,X0
+2 SET X0=$GET(^OR(100,DA,0))
SET ORVP=$PIECE(X0,U,2)
SET ORDG=$PIECE(X0,U,11)
+3 SET ORSTRT=$PIECE(X0,U,8)
SET X=$SELECT(ORSTRT:ORSTRT,1:9999999)
+4 IF ORVP
IF ORDG
KILL ^OR(100,"AW",ORVP,ORDG,X,DA)
+5 QUIT
+6 ;
S1(ORIFN,ORACT,ORVP,ORLOG) ; -- set "AS" xref
+1 ;unsigned
NEW OR0
SET OR0=$GET(^OR(100,ORIFN,8,ORACT,0))
if $PIECE(OR0,U,4)'=2
QUIT
+2 if '$GET(ORLOG)
SET ORLOG=$PIECE(OR0,U)
if '$GET(ORVP)
SET ORVP=$PIECE(^OR(100,ORIFN,0),U,2)
+3 IF ORVP
IF ORLOG
SET ^OR(100,"AS",ORVP,9999999-ORLOG,ORIFN,ORACT)=""
+4 QUIT
S2(ORIFN,ORACT,ORVP,ORLOG) ; -- kill "AS" xref
+1 NEW OR0
if '$GET(ORVP)
SET ORVP=$PIECE(^OR(100,ORIFN,0),U,2)
+2 if '$GET(ORLOG)
SET ORLOG=$PIECE($GET(^OR(100,ORIFN,8,ORACT,0)),U)
+3 IF ORLOG
IF ORVP
KILL ^OR(100,"AS",ORVP,9999999-ORLOG,ORIFN,ORACT)
+4 QUIT
+5 ;
RS(ORIFN,ORACT,ORVP,ORRDT) ; -- set "AR" xref
+1 NEW OR80
+2 if '$GET(ORIFN)
QUIT
if '$GET(ORACT)
QUIT
+3 if '$GET(ORVP)
SET ORVP=$PIECE($GET(^OR(100,ORIFN,0)),U,2)
+4 SET OR80=$GET(^OR(100,ORIFN,8,ORACT,0))
+5 if '$GET(ORRDT)
SET ORRDT=$PIECE(OR80,U,16)
+6 IF ORVP
IF ORRDT
SET ^OR(100,"AR",ORVP,(9999999-ORRDT),ORIFN,ORACT)=""
+7 IF ORVP'["DPT"!ORRDT=""
QUIT
+8 IF $PIECE(OR80,U,2)="NW"
DO PXRMADD(ORIFN,ORVP,ORRDT)
+9 QUIT
+10 ;
PXRMADD(ORIFN,ORVP,ORRDT) ; -- set "PXRM" xref
+1 NEW DAES,OI,OR0,START,X
+2 SET DAES(1)=ORIFN
+3 SET X(1)=ORVP
+4 SET OR0=^OR(100,ORIFN,0)
+5 SET START=$PIECE(OR0,U,8)
+6 SET X(3)=$SELECT(START="":ORRDT,1:START)
+7 SET X(4)=$PIECE(OR0,U,9)
+8 SET OI=0
FOR
SET OI=$ORDER(^OR(100,ORIFN,.1,OI))
if OI'>0
QUIT
Begin DoDot:1
+9 SET X(2)=+$GET(^(OI,0))
SET DAES=OI
+10 DO SOR^ORPXRM(.X,.DAES)
End DoDot:1
+11 QUIT
+12 ;
RK(ORIFN,ORACT,ORVP,ORRDT) ; -- kill "AR" xref
+1 NEW OR80
+2 if '$GET(ORIFN)
QUIT
if '$GET(ORACT)
QUIT
+3 if '$GET(ORVP)
SET ORVP=$PIECE($GET(^OR(100,ORIFN,0)),U,2)
+4 SET OR80=$GET(^OR(100,ORIFN,8,ORACT,0))
+5 if '$GET(ORRDT)
SET ORRDT=$PIECE(OR80,U,16)
+6 IF ORVP
IF ORRDT
KILL ^OR(100,"AR",ORVP,(9999999-ORRDT),ORIFN,ORACT)
+7 IF ORVP'["DPT"!ORRDT=""
QUIT
+8 IF $PIECE(OR80,U,2)="NW"
DO PXRMKILL(ORIFN,ORVP,ORRDT)
+9 QUIT
+10 ;
PXRMKILL(ORIFN,ORVP,ORRDT) ; -- kill "PXRM" xref
+1 NEW DAES,OI,OR0,START,X
+2 SET DAES(1)=ORIFN
+3 SET X(1)=ORVP
+4 SET OR0=^OR(100,ORIFN,0)
+5 SET START=$PIECE(OR0,U,8)
+6 SET X(3)=$SELECT(START="":ORRDT,1:START)
+7 SET X(4)=$PIECE(OR0,U,9)
+8 SET OI=0
FOR
SET OI=$ORDER(^OR(100,ORIFN,.1,OI))
if OI'>0
QUIT
Begin DoDot:1
+9 SET X(2)=+$GET(^(OI,0))
SET DAES=OI
+10 DO KOR^ORPXRM(.X,.DAES)
End DoDot:1
+11 QUIT
+12 ;
VS ; -- set "AEVNT" xref
+1 NEW ORVP,OREVNT
+2 SET ORVP=$PIECE($GET(^OR(100,DA,0)),U,2)
SET OREVNT=$PIECE($GET(^(0)),U,17)
+3 IF ORVP
IF $LENGTH(OREVNT)
SET ^OR(100,"AEVNT",ORVP,OREVNT,DA)=""
+4 QUIT
+5 ;
VK ; -- kill "AEVNT" xref
+1 NEW ORVP,OREVNT
+2 SET ORVP=$PIECE($GET(^OR(100,DA,0)),U,2)
SET OREVNT=$PIECE($GET(^(0)),U,17)
+3 IF ORVP
IF $LENGTH(OREVNT)
KILL ^OR(100,"AEVNT",ORVP,OREVNT,DA)
+4 QUIT
+5 ;
UP(X) ; -- Convert X to upper case
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
