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