ORELR3 ; slc/dcm - Cross check file 100 with file 69 ;2/21/96 13:30 ;
;;3.0;ORDER ENTRY/RESULTS REPORTING;**20,42,169**;Dec 17, 1997
PURG(ORIFN) ;
N ORX,X,ORPK,X3,X,DA,DIK
Q:'$D(ORIFN)
Q:'$D(^OR(100,ORIFN,0))
I $D(^OR(100,ORIFN,3)),$P(^(3),"^",9) S X=$P(^(3),"^",9) I $O(^OR(100,X,2,0)) S $P(^(0),"^",4)=$P(^(0),"^",4)-1 K ^(ORIFN) I '$O(^(0)) D:ORIFN'=X PURG(X)
S (ORX,X)=^OR(100,ORIFN,0),ORPK=$G(^(4)),X3=$G(^(3))
D P(ORPK)
S DA=ORIFN,DIK="^OR(100," D ^DIK
Q
P(ORPK) ;Purge
N LRXODT,LRXSN
I ORPK'[";",ORPK D Q
. S LRXODT=0 F S LRXODT=$O(^LRO(69,"C",+ORPK,LRXODT)) Q:LRXODT<1 D
.. S LRXSN=0 F S LRXSN=$O(^LRO(69,"C",+ORPK,LRXODT,LRXSN)) Q:LRXSN<1 D
... D TST
S LRXODT=$P(ORPK,";",2),LRXSN=$P(ORPK,";",3)
I LRXODT,LRXSN,$D(^LRO(69,LRXODT,1,LRXSN,2,0)) D TST
Q
TST ;Get the test level
N I,X
S I=0 F S I=$O(^OR(100,ORIFN,4.5,"ID","ORDERABLE",I)) Q:I<1 I $D(^OR(100,ORIFN,4.5,I,1)) S X=^(1) I $D(^ORD(101.43,+X,0)) S X=+$P(^(0),"^",2) I X D
. I $D(^LRO(69,LRXODT,1,LRXSN,2,"B",X)) S X=$O(^(X,0)),$P(^LRO(69,LRXODT,1,LRXSN,2,X,0),"^",7)="P"
Q
DC ;Lapse old pending/active/unrel orders
Q:'$D(^OR(100,ORIFN,3))
Q:$P(^OR(100,ORIFN,3),"^",3)'=5&($P(^(3),"^",3)'=11)&($P(^(3),"^",3)'=6) N X3 S X3=$P(^(3),"^",3)
I ORPENDT,ORSTRT<ORPENDT D
. I ORSTRT="",ORENT'<ORPENDT Q
. I X3=5 S PCNT=PCNT+1,TTCNT=TTCNT+1 W "p"
. I X3=6 Q:$D(^LRO(69,LRODT,1,LRSN,0)) S APCNT=APCNT+1,TTCNT=TTCNT+1 W "a"
. I X3=11 S UCNT=UCNT+1,TTCNT=TTCNT+1 W "u"
. I ORAFIX,ORPEND D:ORSTS=11 PURG(ORIFN) D:ORSTS'=11 STATUS^ORCSAVE2(ORIFN,14)
Q
DAD(ORIFN) ;Check mult ord status
Q:'$O(^OR(100,ORIFN,2,0))
N SAME,J,X,D
S SAME=1,J=0
F S J=$O(^OR(100,ORIFN,2,J)) Q:'J I $D(^OR(100,J,3)),$P(^(3),"^",3)'=ORPSTS S SAME=0 Q
Q:SAME
S (J,X,D)=0 F S J=$O(^OR(100,ORIFN,2,J)) Q:J<1 D Q:X
. I '$D(^OR(100,J)) S HCNT=HCNT+1 D WRT^ORELR2(ORIFN,"Bad Child ptr:"_J) D Q
.. I ORAFIX K ^OR(100,ORIFN,2,J) I '$O(^(0)) D PURG(ORIFN)
. I $D(^OR(100,J)) S K=$P($G(^(J,3)),"^",3),X=$S(K=1:"",K=2:"",K=7:"",K=14:"",1:1) Q:X S:K'=1 D=1
I 'X,ORSTS'=$S(D:2,1:1) S PTCNT=PTCNT+1 D WRT^ORELR2(ORIFN,"Parent status update") I ORAFIX S ORSTS=$S(D:2,1:1) I ORSTS'=ORPSTS D STATUS^ORCSAVE2(ORIFN,ORSTS)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORELR3 2237 printed Oct 16, 2024@18:31:04 Page 2
ORELR3 ; slc/dcm - Cross check file 100 with file 69 ;2/21/96 13:30 ;
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**20,42,169**;Dec 17, 1997
PURG(ORIFN) ;
+1 NEW ORX,X,ORPK,X3,X,DA,DIK
+2 if '$DATA(ORIFN)
QUIT
+3 if '$DATA(^OR(100,ORIFN,0))
QUIT
+4 IF $DATA(^OR(100,ORIFN,3))
IF $PIECE(^(3),"^",9)
SET X=$PIECE(^(3),"^",9)
IF $ORDER(^OR(100,X,2,0))
SET $PIECE(^(0),"^",4)=$PIECE(^(0),"^",4)-1
KILL ^(ORIFN)
IF '$ORDER(^(0))
if ORIFN'=X
DO PURG(X)
+5 SET (ORX,X)=^OR(100,ORIFN,0)
SET ORPK=$GET(^(4))
SET X3=$GET(^(3))
+6 DO P(ORPK)
+7 SET DA=ORIFN
SET DIK="^OR(100,"
DO ^DIK
+8 QUIT
P(ORPK) ;Purge
+1 NEW LRXODT,LRXSN
+2 IF ORPK'[";"
IF ORPK
Begin DoDot:1
+3 SET LRXODT=0
FOR
SET LRXODT=$ORDER(^LRO(69,"C",+ORPK,LRXODT))
if LRXODT<1
QUIT
Begin DoDot:2
+4 SET LRXSN=0
FOR
SET LRXSN=$ORDER(^LRO(69,"C",+ORPK,LRXODT,LRXSN))
if LRXSN<1
QUIT
Begin DoDot:3
+5 DO TST
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+6 SET LRXODT=$PIECE(ORPK,";",2)
SET LRXSN=$PIECE(ORPK,";",3)
+7 IF LRXODT
IF LRXSN
IF $DATA(^LRO(69,LRXODT,1,LRXSN,2,0))
DO TST
+8 QUIT
TST ;Get the test level
+1 NEW I,X
+2 SET I=0
FOR
SET I=$ORDER(^OR(100,ORIFN,4.5,"ID","ORDERABLE",I))
if I<1
QUIT
IF $DATA(^OR(100,ORIFN,4.5,I,1))
SET X=^(1)
IF $DATA(^ORD(101.43,+X,0))
SET X=+$PIECE(^(0),"^",2)
IF X
Begin DoDot:1
+3 IF $DATA(^LRO(69,LRXODT,1,LRXSN,2,"B",X))
SET X=$ORDER(^(X,0))
SET $PIECE(^LRO(69,LRXODT,1,LRXSN,2,X,0),"^",7)="P"
End DoDot:1
+4 QUIT
DC ;Lapse old pending/active/unrel orders
+1 if '$DATA(^OR(100,ORIFN,3))
QUIT
+2 if $PIECE(^OR(100,ORIFN,3),"^",3)'=5&($PIECE(^(3),"^",3)'=11)&($PIECE(^(3),"^",3)'=6)
QUIT
NEW X3
SET X3=$PIECE(^(3),"^",3)
+3 IF ORPENDT
IF ORSTRT<ORPENDT
Begin DoDot:1
+4 IF ORSTRT=""
IF ORENT'<ORPENDT
QUIT
+5 IF X3=5
SET PCNT=PCNT+1
SET TTCNT=TTCNT+1
WRITE "p"
+6 IF X3=6
if $DATA(^LRO(69,LRODT,1,LRSN,0))
QUIT
SET APCNT=APCNT+1
SET TTCNT=TTCNT+1
WRITE "a"
+7 IF X3=11
SET UCNT=UCNT+1
SET TTCNT=TTCNT+1
WRITE "u"
+8 IF ORAFIX
IF ORPEND
if ORSTS=11
DO PURG(ORIFN)
if ORSTS'=11
DO STATUS^ORCSAVE2(ORIFN,14)
End DoDot:1
+9 QUIT
DAD(ORIFN) ;Check mult ord status
+1 if '$ORDER(^OR(100,ORIFN,2,0))
QUIT
+2 NEW SAME,J,X,D
+3 SET SAME=1
SET J=0
+4 FOR
SET J=$ORDER(^OR(100,ORIFN,2,J))
if 'J
QUIT
IF $DATA(^OR(100,J,3))
IF $PIECE(^(3),"^",3)'=ORPSTS
SET SAME=0
QUIT
+5 if SAME
QUIT
+6 SET (J,X,D)=0
FOR
SET J=$ORDER(^OR(100,ORIFN,2,J))
if J<1
QUIT
Begin DoDot:1
+7 IF '$DATA(^OR(100,J))
SET HCNT=HCNT+1
DO WRT^ORELR2(ORIFN,"Bad Child ptr:"_J)
Begin DoDot:2
+8 IF ORAFIX
KILL ^OR(100,ORIFN,2,J)
IF '$ORDER(^(0))
DO PURG(ORIFN)
End DoDot:2
QUIT
+9 IF $DATA(^OR(100,J))
SET K=$PIECE($GET(^(J,3)),"^",3)
SET X=$SELECT(K=1:"",K=2:"",K=7:"",K=14:"",1:1)
if X
QUIT
if K'=1
SET D=1
End DoDot:1
if X
QUIT
+10 IF 'X
IF ORSTS'=$SELECT(D:2,1:1)
SET PTCNT=PTCNT+1
DO WRT^ORELR2(ORIFN,"Parent status update")
IF ORAFIX
SET ORSTS=$SELECT(D:2,1:1)
IF ORSTS'=ORPSTS
DO STATUS^ORCSAVE2(ORIFN,ORSTS)
+11 QUIT
