- ORELR2 ; slc/dcm - Cross check file 100 with file 69 ;2/21/96 13:30 ;
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**20,42,169,323**;Dec 17, 1997;Build 10
- A ;Enter here
- N X,ORENT,ORSTS,ORX1,ORX,ORX3,ORSDT,ORITEM,ORX4,ORX6,ORDAD,ORX1,ORDFN,ORPCL,ORSTS,ORSTRT,ORENT,ORWHO,ORSIB,ORPSTS,LRDFN,LRODT,LRORD,LRSN,LRSTS
- S (ORENT,ORSTS,ORX1)=""
- I '$D(^OR(100,ORIFN,0)) D WRT(ORIFN,"No ^OR(100,ORIFN,0)") K:ORAFIX ^OR(100,ORIFN) Q
- I '$D(^OR(100,ORIFN,3)) D WRT(ORIFN,"No ^OR(100,ORIFN,3)") D:ORAFIX PURG^ORELR3(ORIFN) Q
- S ORX=^OR(100,ORIFN,0),ORX3=$G(^(3)),ORSDT=$P(ORX3,"^",6),ORITEM=$P(ORX3,"^",7),ORX4=$G(^(4)),ORX6=$G(^(6)),ORDAD=$O(^(2,0)),ORX1=$O(^OR(100,ORIFN,1,0)),ORX1=$E($G(^(+ORX1,0)),1,15),ORDFN=$P(ORX,"^",2)
- I '$P(ORX,"^",14) W ORIFN,! D WRT(ORIFN,"No package defined") D:ORAFIX PURG^ORELR3(ORIFN) Q
- Q:$P(ORX,"^",14)'=PKG
- Q:ORDFN'[";DPT("
- S ORPCL=$P(ORX3,"^",4),ORSTS=$P(ORX3,"^",3),ORSTRT=$P(ORX,"^",8),ORENT=$P(ORX,"^",7),ORWHO=$P(ORX,"^",6),ORSIB=$P(ORX3,"^",9)
- D NOW^%DTC
- I ORENT>+($E(%,1,10)-.01) Q
- I ORSTS=99 D WRT(ORIFN,"No Status",1) S NCNT=NCNT+1 Q
- I ORPCL,ORPCL[";ORD(101,",$D(^ORD(101,+ORPCL,0)),$P(^(0),"^")["ORGY " Q
- ;I $P(ORX3,"^",8),DT>$P(ORENT,".") D ;DJE-VM *323 - it's not appropriate to purge unveiled orders since OR*3*282
- ;. I ORSTS=2,ORAFIX S $P(^OR(100,ORIFN,3),"^",8)="" Q ;Unveil completed order
- ;. S VCNT=VCNT+1
- ;. D WRT(ORIFN,"Old Veiled order: ORPK="_ORX4)
- ;. D:ORAFIX PURG^ORELR3(ORIFN)
- I ORDAD S ORPSTS=ORSTS D DAD^ORELR3(ORIFN) Q
- I ORSIB D
- . I '$D(^OR(100,ORSIB)) S SIBCNT=SIBCNT+1 D WRT(ORIFN,"Child order with no parent") S:ORAFIX $P(^OR(100,ORIFN,3),"^",9)="" Q
- . I '$D(^OR(100,ORSIB,2,ORIFN)) S SIBPCNT=SIBPCNT+1 D WRT(ORIFN,"Child order with missing parent pointer") I ORAFIX S ^OR(100,ORSIB,2,ORIFN,0)=ORIFN
- I ORSTS=11,ORPENDT,ORSTRT<ORPENDT D DC^ORELR3 Q
- Q:$P(ORX3,"^",3)=11
- Q:$P(ORX3,"^",3)=10
- I $L($P(ORX4,"^",4,99)) Q:$P(ORX3,"^",3)=1 D Q
- . I 'ORSTS S BSCNT=BSCNT+1 D WRT(ORIFN,"Bad package link, null status:"_ORX4) I '$P(ORX4,"^",4) D:ORAFIX PURG^ORELR3(ORIFN) Q
- . I ORSTS'=1 S UCCNT=UCCNT+1 D WRT(ORIFN,"Unrecognized package link:"_ORX4) D:ORAFIX STATUS^ORCSAVE2(ORIFN,1)
- I '$D(^OR(100,ORIFN,4)) D Q
- . I ORSTS'=1,ORSTS'=2,'(ORSTS>8&(ORSTS<15)),$P(ORX3,"^",13)'=2 D WRT(ORIFN,"No package node") S UCCNT=UCCNT+1 D:ORAFIX STATUS^ORCSAVE2(ORIFN,1)
- I '$L(^OR(100,ORIFN,4)) D Q
- . I ORSTS'=1,ORSTS'=2,'(ORSTS>8&(ORSTS<15)) D WRT(ORIFN,"Empty package node") S UCCNT=UCCNT+1 D:ORAFIX STATUS^ORCSAVE2(ORIFN,1)
- I ORX4["^" D Q
- . I ORSTS=""!(ORSTS=1)!(ORSTS=2)!(ORSTS=14)!(ORSTS=12) Q
- . S UNCNT=UNCNT+1
- . I ORLRO,'$D(^LRO(69,+ORX4,1,$P(ORX4,"^",2),2,$P(ORX4,"^",3))) D WRT(ORIFN,"Didn't get converted, NOT IN 69") D:ORAFIX STATUS^ORCSAVE2(ORIFN,14) Q
- . I '$D(^LRO(69,+ORX4,1,+$P(ORX4,"^",2))) D WRT(ORIFN,"Didn't get converted") D:ORAFIX STATUS^ORCSAVE2(ORIFN,14) Q
- . S UNCNT=UNCNT-1
- I ORX4'[";" D Q
- . I ORLRO,'$D(^LRO(69,"C",+ORX4)),ORSTS'=14,ORSTS'=1,ORSTS'=2 S NOCNT=NOCNT+1 D WRT(ORIFN,"ORD# not in 69:"_ORX4) D:ORAFIX STATUS^ORCSAVE2(ORIFN,14)
- S LRORD=+ORX4,LRODT=$P(ORX4,";",2),LRSN=$P(ORX4,";",3),LRSTS=""
- I 'LRORD!('LRODT)!('LRSN),ORSTS'=1,ORSTS'=14,ORSTS'=2 D WRT(ORIFN,"Invalid ORPK:"_LRORD_";"_LRODT_";"_LRSN) S IVCNT=IVCNT+1 D:ORAFIX STATUS^ORCSAVE2(ORIFN,14) Q
- I ORLRO,ORSTS'=1,ORSTS'=14,ORSTS'=2,LRODT,LRSN,'$D(^LRO(69,LRODT,1,LRSN,0)) S LCNT=LCNT+1 D WRT(ORIFN,"No entry in 69:"_LRODT_";"_LRSN) D:ORAFIX STATUS^ORCSAVE2(ORIFN,14) Q
- I ORDFN[";DPT(",LRODT,LRSN S LRDFN=+$G(^DPT(+ORDFN,"LR")),X=+$G(^LRO(69,LRODT,1,LRSN,0)) I X,X'=LRDFN S X="Wrong patient! OR:"_LRDFN_" LR:"_X_" ORPK:"_LRODT_";"_LRSN,DCNT=DCNT+1 D WRT(ORIFN,X,1) Q
- I 'ORWHO D WRT(ORIFN,"No 'Entered by'",1) S WICNT=WICNT+1
- I '$P(ORX,"^",4),LRODT,LRSN S PHCNT=PHCNT+1 D
- . S X=$P($G(^LRO(69,LRODT,1,LRSN,0)),"^",6)
- . D WRT(ORIFN,"No Physician in 100"_$S('X:" or 69",1:""),$S(X:"",1:1))
- . I X,ORAFIX S $P(^OR(100,ORIFN,0),"^",4)=X S:'$P(^(3),"^",7) $P(^(3),"^",7)=X
- I $D(^LRO(69,+LRODT,1,+LRSN,1)) S LRSTS=$P(^(1),"^",4)
- S I=0
- I LRSTS="",$D(^LRO(69,+LRODT,1,+LRSN,6)) S J=0 F S J=$O(^LRO(69,LRODT,1,LRSN,6,J)) Q:J<1 I ^(J,0)["NO DRAW for test" S I=1 Q
- I I,ORSTS'=2,ORSTS'=1,ORSTS'=9 D WRT(ORIFN,"Active canceled order") S ACNT=ACNT+1 D:ORAFIX STATUS^ORCSAVE2(ORIFN,1)
- I ORSTS=9 S ICCNT=ICCNT+1 D WRT(ORIFN,"Incomplete should be Complete") D:ORAFIX STATUS^ORCSAVE2(ORIFN,2)
- I ORSTS'=1,ORSTS'=2,ORSTS'=9,$D(^LRO(69,+LRODT,1,+LRSN,3)),$P(^(3),"^",2) N LRTN S LRTN=0 F S LRTN=$O(^LRO(69,LRODT,1,LRSN,2,LRTN)) Q:'LRTN S X=^(LRTN,0) I $P(X,"^",7)=ORIFN,$P(X,"^",3),$P(X,"^",4),$P(X,"^",5) D
- . S X1=$G(^LRO(68,$P(X,"^",4),1,$P(X,"^",3),1,$P(X,"^",5),4,+X,0))
- . I $P(X1,"^",5) D WRT(ORIFN,"Status should be Complete") S STCNT=STCNT+1 D:ORAFIX STATUS^ORCSAVE2(ORIFN,2)
- I ORSTS'=1,ORSTS'=2,ORSTS'=13,ORSTS'=14 N ORI,ORX S ORI=0 F S ORI=$O(^OR(100,ORIFN,4.5,"ID","ORDERABLE",ORI)) Q:ORI<1 I $D(^OR(100,ORIFN,4.5,ORI,1)) S ORX=^(1) I $D(^ORD(101.43,+ORX,0)) S ORX=+$P(^(0),"^",2) I ORX D
- . I $D(^LRO(69,LRODT,1,LRSN,2,"B",ORX)) S ORX=$O(^(ORX,0)) I '$L($P(^LRO(69,LRODT,1,LRSN,2,ORX,0),"^",7)) D WRT(ORIFN,"Missing pointer to 100") S OCNT=OCNT+1 I ORAFIX S $P(^LRO(69,LRODT,1,LRSN,2,ORX,0),"^",7)=ORIFN
- D DC^ORELR3
- Q
- WRT(ORIFN,TEXT,FIX) ;Disp
- S CNT=CNT+1,TTCNT=TTCNT+1
- Q:$E(IOST,1,2)="P-"
- ;I CNT>100 W !!,"Continue" S %=1 D YN^DICN S CNT=0 I %=2 S END=1
- ;W !,ORIFN_"=>"_ORX1_"<"_$G(ORENT)_">"_$G(ORSTS)_"<"_TEXT_$S($G(FIX):">Not fixed",1:"")
- W "."
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORELR2 5494 printed Mar 13, 2025@21:35:25 Page 2
- ORELR2 ; slc/dcm - Cross check file 100 with file 69 ;2/21/96 13:30 ;
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**20,42,169,323**;Dec 17, 1997;Build 10
- A ;Enter here
- +1 NEW X,ORENT,ORSTS,ORX1,ORX,ORX3,ORSDT,ORITEM,ORX4,ORX6,ORDAD,ORX1,ORDFN,ORPCL,ORSTS,ORSTRT,ORENT,ORWHO,ORSIB,ORPSTS,LRDFN,LRODT,LRORD,LRSN,LRSTS
- +2 SET (ORENT,ORSTS,ORX1)=""
- +3 IF '$DATA(^OR(100,ORIFN,0))
- DO WRT(ORIFN,"No ^OR(100,ORIFN,0)")
- if ORAFIX
- KILL ^OR(100,ORIFN)
- QUIT
- +4 IF '$DATA(^OR(100,ORIFN,3))
- DO WRT(ORIFN,"No ^OR(100,ORIFN,3)")
- if ORAFIX
- DO PURG^ORELR3(ORIFN)
- QUIT
- +5 SET ORX=^OR(100,ORIFN,0)
- SET ORX3=$GET(^(3))
- SET ORSDT=$PIECE(ORX3,"^",6)
- SET ORITEM=$PIECE(ORX3,"^",7)
- SET ORX4=$GET(^(4))
- SET ORX6=$GET(^(6))
- SET ORDAD=$ORDER(^(2,0))
- SET ORX1=$ORDER(^OR(100,ORIFN,1,0))
- SET ORX1=$EXTRACT($GET(^(+ORX1,0)),1,15)
- SET ORDFN=$PIECE(ORX,"^",2)
- +6 IF '$PIECE(ORX,"^",14)
- WRITE ORIFN,!
- DO WRT(ORIFN,"No package defined")
- if ORAFIX
- DO PURG^ORELR3(ORIFN)
- QUIT
- +7 if $PIECE(ORX,"^",14)'=PKG
- QUIT
- +8 if ORDFN'[";DPT("
- QUIT
- +9 SET ORPCL=$PIECE(ORX3,"^",4)
- SET ORSTS=$PIECE(ORX3,"^",3)
- SET ORSTRT=$PIECE(ORX,"^",8)
- SET ORENT=$PIECE(ORX,"^",7)
- SET ORWHO=$PIECE(ORX,"^",6)
- SET ORSIB=$PIECE(ORX3,"^",9)
- +10 DO NOW^%DTC
- +11 IF ORENT>+($EXTRACT(%,1,10)-.01)
- QUIT
- +12 IF ORSTS=99
- DO WRT(ORIFN,"No Status",1)
- SET NCNT=NCNT+1
- QUIT
- +13 IF ORPCL
- IF ORPCL[";ORD(101,"
- IF $DATA(^ORD(101,+ORPCL,0))
- IF $PIECE(^(0),"^")["ORGY "
- QUIT
- +14 ;I $P(ORX3,"^",8),DT>$P(ORENT,".") D ;DJE-VM *323 - it's not appropriate to purge unveiled orders since OR*3*282
- +15 ;. I ORSTS=2,ORAFIX S $P(^OR(100,ORIFN,3),"^",8)="" Q ;Unveil completed order
- +16 ;. S VCNT=VCNT+1
- +17 ;. D WRT(ORIFN,"Old Veiled order: ORPK="_ORX4)
- +18 ;. D:ORAFIX PURG^ORELR3(ORIFN)
- +19 IF ORDAD
- SET ORPSTS=ORSTS
- DO DAD^ORELR3(ORIFN)
- QUIT
- +20 IF ORSIB
- Begin DoDot:1
- +21 IF '$DATA(^OR(100,ORSIB))
- SET SIBCNT=SIBCNT+1
- DO WRT(ORIFN,"Child order with no parent")
- if ORAFIX
- SET $PIECE(^OR(100,ORIFN,3),"^",9)=""
- QUIT
- +22 IF '$DATA(^OR(100,ORSIB,2,ORIFN))
- SET SIBPCNT=SIBPCNT+1
- DO WRT(ORIFN,"Child order with missing parent pointer")
- IF ORAFIX
- SET ^OR(100,ORSIB,2,ORIFN,0)=ORIFN
- End DoDot:1
- +23 IF ORSTS=11
- IF ORPENDT
- IF ORSTRT<ORPENDT
- DO DC^ORELR3
- QUIT
- +24 if $PIECE(ORX3,"^",3)=11
- QUIT
- +25 if $PIECE(ORX3,"^",3)=10
- QUIT
- +26 IF $LENGTH($PIECE(ORX4,"^",4,99))
- if $PIECE(ORX3,"^",3)=1
- QUIT
- Begin DoDot:1
- +27 IF 'ORSTS
- SET BSCNT=BSCNT+1
- DO WRT(ORIFN,"Bad package link, null status:"_ORX4)
- IF '$PIECE(ORX4,"^",4)
- if ORAFIX
- DO PURG^ORELR3(ORIFN)
- QUIT
- +28 IF ORSTS'=1
- SET UCCNT=UCCNT+1
- DO WRT(ORIFN,"Unrecognized package link:"_ORX4)
- if ORAFIX
- DO STATUS^ORCSAVE2(ORIFN,1)
- End DoDot:1
- QUIT
- +29 IF '$DATA(^OR(100,ORIFN,4))
- Begin DoDot:1
- +30 IF ORSTS'=1
- IF ORSTS'=2
- IF '(ORSTS>8&(ORSTS<15))
- IF $PIECE(ORX3,"^",13)'=2
- DO WRT(ORIFN,"No package node")
- SET UCCNT=UCCNT+1
- if ORAFIX
- DO STATUS^ORCSAVE2(ORIFN,1)
- End DoDot:1
- QUIT
- +31 IF '$LENGTH(^OR(100,ORIFN,4))
- Begin DoDot:1
- +32 IF ORSTS'=1
- IF ORSTS'=2
- IF '(ORSTS>8&(ORSTS<15))
- DO WRT(ORIFN,"Empty package node")
- SET UCCNT=UCCNT+1
- if ORAFIX
- DO STATUS^ORCSAVE2(ORIFN,1)
- End DoDot:1
- QUIT
- +33 IF ORX4["^"
- Begin DoDot:1
- +34 IF ORSTS=""!(ORSTS=1)!(ORSTS=2)!(ORSTS=14)!(ORSTS=12)
- QUIT
- +35 SET UNCNT=UNCNT+1
- +36 IF ORLRO
- IF '$DATA(^LRO(69,+ORX4,1,$PIECE(ORX4,"^",2),2,$PIECE(ORX4,"^",3)))
- DO WRT(ORIFN,"Didn't get converted, NOT IN 69")
- if ORAFIX
- DO STATUS^ORCSAVE2(ORIFN,14)
- QUIT
- +37 IF '$DATA(^LRO(69,+ORX4,1,+$PIECE(ORX4,"^",2)))
- DO WRT(ORIFN,"Didn't get converted")
- if ORAFIX
- DO STATUS^ORCSAVE2(ORIFN,14)
- QUIT
- +38 SET UNCNT=UNCNT-1
- End DoDot:1
- QUIT
- +39 IF ORX4'[";"
- Begin DoDot:1
- +40 IF ORLRO
- IF '$DATA(^LRO(69,"C",+ORX4))
- IF ORSTS'=14
- IF ORSTS'=1
- IF ORSTS'=2
- SET NOCNT=NOCNT+1
- DO WRT(ORIFN,"ORD# not in 69:"_ORX4)
- if ORAFIX
- DO STATUS^ORCSAVE2(ORIFN,14)
- End DoDot:1
- QUIT
- +41 SET LRORD=+ORX4
- SET LRODT=$PIECE(ORX4,";",2)
- SET LRSN=$PIECE(ORX4,";",3)
- SET LRSTS=""
- +42 IF 'LRORD!('LRODT)!('LRSN)
- IF ORSTS'=1
- IF ORSTS'=14
- IF ORSTS'=2
- DO WRT(ORIFN,"Invalid ORPK:"_LRORD_";"_LRODT_";"_LRSN)
- SET IVCNT=IVCNT+1
- if ORAFIX
- DO STATUS^ORCSAVE2(ORIFN,14)
- QUIT
- +43 IF ORLRO
- IF ORSTS'=1
- IF ORSTS'=14
- IF ORSTS'=2
- IF LRODT
- IF LRSN
- IF '$DATA(^LRO(69,LRODT,1,LRSN,0))
- SET LCNT=LCNT+1
- DO WRT(ORIFN,"No entry in 69:"_LRODT_";"_LRSN)
- if ORAFIX
- DO STATUS^ORCSAVE2(ORIFN,14)
- QUIT
- +44 IF ORDFN[";DPT("
- IF LRODT
- IF LRSN
- SET LRDFN=+$GET(^DPT(+ORDFN,"LR"))
- SET X=+$GET(^LRO(69,LRODT,1,LRSN,0))
- IF X
- IF X'=LRDFN
- SET X="Wrong patient! OR:"_LRDFN_" LR:"_X_" ORPK:"_LRODT_";"_LRSN
- SET DCNT=DCNT+1
- DO WRT(ORIFN,X,1)
- QUIT
- +45 IF 'ORWHO
- DO WRT(ORIFN,"No 'Entered by'",1)
- SET WICNT=WICNT+1
- +46 IF '$PIECE(ORX,"^",4)
- IF LRODT
- IF LRSN
- SET PHCNT=PHCNT+1
- Begin DoDot:1
- +47 SET X=$PIECE($GET(^LRO(69,LRODT,1,LRSN,0)),"^",6)
- +48 DO WRT(ORIFN,"No Physician in 100"_$SELECT('X:" or 69",1:""),$SELECT(X:"",1:1))
- +49 IF X
- IF ORAFIX
- SET $PIECE(^OR(100,ORIFN,0),"^",4)=X
- if '$PIECE(^(3),"^",7)
- SET $PIECE(^(3),"^",7)=X
- End DoDot:1
- +50 IF $DATA(^LRO(69,+LRODT,1,+LRSN,1))
- SET LRSTS=$PIECE(^(1),"^",4)
- +51 SET I=0
- +52 IF LRSTS=""
- IF $DATA(^LRO(69,+LRODT,1,+LRSN,6))
- SET J=0
- FOR
- SET J=$ORDER(^LRO(69,LRODT,1,LRSN,6,J))
- if J<1
- QUIT
- IF ^(J,0)["NO DRAW for test"
- SET I=1
- QUIT
- +53 IF I
- IF ORSTS'=2
- IF ORSTS'=1
- IF ORSTS'=9
- DO WRT(ORIFN,"Active canceled order")
- SET ACNT=ACNT+1
- if ORAFIX
- DO STATUS^ORCSAVE2(ORIFN,1)
- +54 IF ORSTS=9
- SET ICCNT=ICCNT+1
- DO WRT(ORIFN,"Incomplete should be Complete")
- if ORAFIX
- DO STATUS^ORCSAVE2(ORIFN,2)
- +55 IF ORSTS'=1
- IF ORSTS'=2
- IF ORSTS'=9
- IF $DATA(^LRO(69,+LRODT,1,+LRSN,3))
- IF $PIECE(^(3),"^",2)
- NEW LRTN
- SET LRTN=0
- FOR
- SET LRTN=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRTN))
- if 'LRTN
- QUIT
- SET X=^(LRTN,0)
- IF $PIECE(X,"^",7)=ORIFN
- IF $PIECE(X,"^",3)
- IF $PIECE(X,"^",4)
- IF $PIECE(X,"^",5)
- Begin DoDot:1
- +56 SET X1=$GET(^LRO(68,$PIECE(X,"^",4),1,$PIECE(X,"^",3),1,$PIECE(X,"^",5),4,+X,0))
- +57 IF $PIECE(X1,"^",5)
- DO WRT(ORIFN,"Status should be Complete")
- SET STCNT=STCNT+1
- if ORAFIX
- DO STATUS^ORCSAVE2(ORIFN,2)
- End DoDot:1
- +58 IF ORSTS'=1
- IF ORSTS'=2
- IF ORSTS'=13
- IF ORSTS'=14
- NEW ORI,ORX
- SET ORI=0
- FOR
- SET ORI=$ORDER(^OR(100,ORIFN,4.5,"ID","ORDERABLE",ORI))
- if ORI<1
- QUIT
- IF $DATA(^OR(100,ORIFN,4.5,ORI,1))
- SET ORX=^(1)
- IF $DATA(^ORD(101.43,+ORX,0))
- SET ORX=+$PIECE(^(0),"^",2)
- IF ORX
- Begin DoDot:1
- +59 IF $DATA(^LRO(69,LRODT,1,LRSN,2,"B",ORX))
- SET ORX=$ORDER(^(ORX,0))
- IF '$LENGTH($PIECE(^LRO(69,LRODT,1,LRSN,2,ORX,0),"^",7))
- DO WRT(ORIFN,"Missing pointer to 100")
- SET OCNT=OCNT+1
- IF ORAFIX
- SET $PIECE(^LRO(69,LRODT,1,LRSN,2,ORX,0),"^",7)=ORIFN
- End DoDot:1
- +60 DO DC^ORELR3
- +61 QUIT
- WRT(ORIFN,TEXT,FIX) ;Disp
- +1 SET CNT=CNT+1
- SET TTCNT=TTCNT+1
- +2 if $EXTRACT(IOST,1,2)="P-"
- QUIT
- +3 ;I CNT>100 W !!,"Continue" S %=1 D YN^DICN S CNT=0 I %=2 S END=1
- +4 ;W !,ORIFN_"=>"_ORX1_"<"_$G(ORENT)_">"_$G(ORSTS)_"<"_TEXT_$S($G(FIX):">Not fixed",1:"")
- +5 WRITE "."
- +6 QUIT
