Routine: ORX8

ORX8 ; slc/dcm,MKB - OE/RR Orders file extracts ; 08 May 2002  2:12 PM

 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**13,21,48,68,92,141,163**;Dec 17, 1997

EN(ORIFN) ;Returns data from file 100 in the ORUPCHUK array [DBIA#871]

 Q:'$D(ORIFN)  Q:'$D(^OR(100,+ORIFN,0))  K ORUPCHUK

D A

 K ORTX,X0,X3,%X,%Y,J,ORINDX,X

A S X0=^OR(100,ORIFN,0),X3=^(3),ORUPCHUK("ORPK")=$S($D(^(4)):^(4),1:"")

 S ORUPCHUK("ORVP")=$P(X0,"^",2),ORUPCHUK("ORPCL")=$P(X0,"^",5),X=$P(X0,"^",6),ORUPCHUK("ORDUZ")=X_"^"_$S($D(^VA(200,+X,0)):$P(^(0),"^"),1:""),ORUPCHUK("ORODT")=$P(X0,"^",7),ORUPCHUK("ORSTOP")=$P(X0,"^",9),ORUPCHUK("ORL")=$P(X0,"^",10)

 S X=$P(X0,"^",11),ORUPCHUK("ORTO")=X_"^"_$S($D(^ORD(100.98,+X,0)):$P(^(0),"^"),1:"")

 S X=$P(X3,"^",3),ORUPCHUK("ORSTS")=X_"^"_$P(^ORD(100.01,X,0),"^"),ORUPCHUK("ORSTRT")=$P(X0,"^",8),X=$P(X0,"^",4),(ORUPCHUK("ORNP"),ORUPCHUK("ORPV"))=X_"^"_$S(X:$S($D(^VA(200,+X,0)):$P(^(0),"^"),1:""),1:"")

 D TEXT^ORQ12(.ORTX,ORIFN,$G(ORLENGTH))

 I $O(ORTX(0)) S %X="ORTX(",%Y="ORUPCHUK(""ORTX""," D %XY^%RCR

VALUE(IFN,ID,INST,FORMAT) ; -- Returns value of prompt by ID

 I '$G(IFN)!('$D(^OR(100,+$G(IFN),0)))!($G(ID)="") Q ""

 N I,Y S I=0,Y="" S:'$G(INST) INST=1

 F  S I=$O(^OR(100,+IFN,4.5,"ID",ID,I)) Q:I'>0  I $P($G(^OR(100,+IFN,4.5,+I,0)),U,3)=INST S PRMT=+$P(^(0),U,2),Y=$G(^(1)) Q

 I $L(Y),$G(PRMT),$G(FORMAT)="E" D  ; get external form of Y

 . N ORDIALOG S ORDIALOG(PRMT,0)=$G(^ORD(101.41,PRMT,1))

 . S ORDIALOG(PRMT,1)=Y,Y=$$EXT^ORCD(PRMT,1)

Q Y

OI(IFN) ; -- Returns [first] orderable item for order IFN in the format

 ;    ifn ^ name ^ pkg id   [DBIA#2467]

 I '$G(IFN)!('$D(^OR(100,+$G(IFN),0))) Q ""

 N I,X,Y S I=$O(^OR(100,+IFN,.1,0)),X=$G(^(+I,0)),Y=""

 I X,$D(^ORD(101.43,+X,0)) S Y=+X_U_$P(^(0),U,1,2)

Q Y

LATEST(ORPAT,ORIT,ORY) ; -- Return most recent orders for ORPAT,ORIT as

 ;        ORY = total number of orders found (or 0 if none found)

 ; ORY(ORSTS) = ORIFN ^ Ord'd By ^ Entered ^ StartDt ^ StopDt ^ Loc ^ Sts

 ; where ORSTS is the ien in the Order Status file #100.01  [DBIA#2842]

 N ORVP,ORIDT,ORIFN,OR0,OR3,ORSTS,ORSTSNM

 S ORVP=+ORPAT_";DPT(",ORY=0 Q:'$G(ORPAT)  Q:'$G(ORIT)  ;invalid input

 S ORIDT=0 F  S ORIDT=$O(^OR(100,"AOI",+ORIT,ORVP,ORIDT)) Q:ORIDT'>0  D

 . S ORIFN=0 F  S ORIFN=$O(^OR(100,"AOI",+ORIT,ORVP,ORIDT,ORIFN)) Q:ORIFN'>0  D

 .. S OR0=$G(^OR(100,+ORIFN,0)),OR3=$G(^(3)),ORSTS=+$P(OR3,U,3)

 .. Q:ORSTS'>0  Q:$G(ORY(ORSTS))  ;return only latest order per status

 .. S ORSTSNM=$$LOW^XLFSTR($P($G(^ORD(100.01,ORSTS,0)),U))

 .. S ORY=ORY+1,ORY(ORSTS)=ORIFN_U_$P(OR0,U,4)_U_$P(OR0,U,7,10)_U_ORSTSNM

DELAYED(ORY,ORDER) ; -- Return delayed order(s) with same OrdItem as ORDER

 ;    in ORY(ORIFN) = PatEventPtr ^ EventName

 N ORI,ORIT,ORIFN S (ORY,ORI)=0

 F  S ORI=$O(^OR(100,+ORDER,.1,ORI)) Q:ORI'>0  S ORIT=+$G(^(ORI,0)) D

 . S EVT=0 F  S EVT=$O(^ORE(100.2,"AE",+ORVP,EVT)) Q:EVT<1  S PTEVT=+$O(^(EVT,0)) D  ;pending events

 .. S ORIFN=0 F  S ORIFN=+$O(^OR(100,"AEVNT",ORVP,PTEVT,ORIFN)) Q:ORIFN<1  D  ;delayed orders

 ... Q:ORIFN=+ORDER  Q:'$D(^OR(100,ORIFN,.1,"B",ORIT))

 ... Q:"^1^2^7^12^13^14^"[(U_$P($G(^OR(100,ORIFN,3)),U,3)_U)  ;terminated

 ... S ORY=ORY+1,ORY(ORIFN)=PTEVT_U_$P($G(^ORD(100.5,EVT,0)),U)

PKGID(ORIFN) ; -- Return package identifier for order ORIFN  [DBIA#3071]

 Q $G(^OR(100,+$G(ORIFN),4))

ES(ORDER) ; -- Returns the signature status of ORDER [DBIA#3632]

 ;  -1 = invalid order#

 ;  "" = no signature required

 ;   0 = not signed (needs ES)

 ;   1 = electronically or digitally signed

 ;   2 = signed on chart

 ;   3 = corrected or canceled order

 N X,Y,DA I '$G(ORDER)!'$D(^OR(100,+$G(ORDER),0)) Q -1

 S DA=+$P(ORDER,";",2) S:DA<1 DA=+$P($G(^OR(100,+ORDER,3)),U,7)

 S X=$P($G(^OR(100,+ORDER,8,DA,0)),U,4)

 S Y=$S(X=2:0,X=1!(X=7):1,X=0!(X=4):2,X=5!(X=6):3,1:"")

Q Y

AND(DAD) ; -- Return 1 or 0, if all conjunctions are AND [DBIA#3632]

 N I,Y S I=0,Y=1

 F  S I=+$O(^OR(100,+$G(DAD),4.5,"ID","CONJ",I)) Q:I<1  I $E($G(^OR(100,+$G(DAD),4.5,I,1)))'="A" S Y=0 Q

Q Y

ORX8      ; slc/dcm,MKB - OE/RR Orders file extracts ; 08 May 2002  2:12 PM

 +1       ;;3.0;ORDER ENTRY/RESULTS REPORTING;**13,21,48,68,92,141,163**;Dec 17, 1997

 +2       ;

EN(ORIFN) ;Returns data from file 100 in the ORUPCHUK array [DBIA#871]

 +1        IF '$DATA(ORIFN)

               QUIT

           IF '$DATA(^OR(100,+ORIFN,0))

               QUIT

           KILL ORUPCHUK

 +2        DO A

 +3        KILL ORTX,X0,X3,%X,%Y,J,ORINDX,X

 +4        QUIT

A          SET X0=^OR(100,ORIFN,0)

           SET X3=^(3)

           SET ORUPCHUK("ORPK")=$SELECT($DATA(^(4)):^(4),1:"")

 +1        SET ORUPCHUK("ORVP")=$PIECE(X0,"^",2)

           SET ORUPCHUK("ORPCL")=$PIECE(X0,"^",5)

           SET X=$PIECE(X0,"^",6)

           SET ORUPCHUK("ORDUZ")=X_"^"_$SELECT($DATA(^VA(200,+X,0)):$PIECE(^(0),"^"),1:"")

           SET ORUPCHUK("ORODT")=$PIECE(X0,"^",7)

           SET ORUPCHUK("ORSTOP")=$PIECE(X0,"^",9)

           SET ORUPCHUK("ORL")=$PIECE(X0,"^",10)

 +2        SET X=$PIECE(X0,"^",11)

           SET ORUPCHUK("ORTO")=X_"^"_$SELECT($DATA(^ORD(100.98,+X,0)):$PIECE(^(0),"^"),1:"")

 +3        SET X=$PIECE(X3,"^",3)

           SET ORUPCHUK("ORSTS")=X_"^"_$PIECE(^ORD(100.01,X,0),"^")

           SET ORUPCHUK("ORSTRT")=$PIECE(X0,"^",8)

           SET X=$PIECE(X0,"^",4)

           SET (ORUPCHUK("ORNP"),ORUPCHUK("ORPV"))=X_"^"_$SELECT(X:$SELECT($DATA(^VA(200,+X,0)):$PIECE(^(0),"^"),1:""),1:"")

 +4        DO TEXT^ORQ12(.ORTX,ORIFN,$GET(ORLENGTH))

 +5        IF $ORDER(ORTX(0))

               SET %X="ORTX("

               SET %Y="ORUPCHUK(""ORTX"","

               DO %XY^%RCR

 +6        QUIT

 +7       ;

VALUE(IFN,ID,INST,FORMAT) ; -- Returns value of prompt by ID

 +1        IF '$GET(IFN)!('$DATA(^OR(100,+$GET(IFN),0)))!($GET(ID)="")

               QUIT ""

 +2        NEW I,Y

           SET I=0

           SET Y=""

           IF '$GET(INST)

               SET INST=1

 +3        FOR

               SET I=$ORDER(^OR(100,+IFN,4.5,"ID",ID,I))

               IF I'>0

                   QUIT

               IF $PIECE($GET(^OR(100,+IFN,4.5,+I,0)),U,3)=INST

                   SET PRMT=+$PIECE(^(0),U,2)

                   SET Y=$GET(^(1))

                   QUIT

 +4       ; get external form of Y

           IF $LENGTH(Y)

               IF $GET(PRMT)

                   IF $GET(FORMAT)="E"

                       Begin DoDot:1

 +5                        NEW ORDIALOG

                           SET ORDIALOG(PRMT,0)=$GET(^ORD(101.41,PRMT,1))

 +6                        SET ORDIALOG(PRMT,1)=Y

                           SET Y=$$EXT^ORCD(PRMT,1)

                       End DoDot:1

 +7        QUIT Y

 +8       ;

OI(IFN)   ; -- Returns [first] orderable item for order IFN in the format

 +1       ;    ifn ^ name ^ pkg id   [DBIA#2467]

 +2        IF '$GET(IFN)!('$DATA(^OR(100,+$GET(IFN),0)))

               QUIT ""

 +3        NEW I,X,Y

           SET I=$ORDER(^OR(100,+IFN,.1,0))

           SET X=$GET(^(+I,0))

           SET Y=""

 +4        IF X

               IF $DATA(^ORD(101.43,+X,0))

                   SET Y=+X_U_$PIECE(^(0),U,1,2)

 +5        QUIT Y

 +6       ;

LATEST(ORPAT,ORIT,ORY) ; -- Return most recent orders for ORPAT,ORIT as

 +1       ;        ORY = total number of orders found (or 0 if none found)

 +2       ; ORY(ORSTS) = ORIFN ^ Ord'd By ^ Entered ^ StartDt ^ StopDt ^ Loc ^ Sts

 +3       ; where ORSTS is the ien in the Order Status file #100.01  [DBIA#2842]

 +4       ;

 +5        NEW ORVP,ORIDT,ORIFN,OR0,OR3,ORSTS,ORSTSNM

 +6       ;invalid input

           SET ORVP=+ORPAT_";DPT("

           SET ORY=0

           IF '$GET(ORPAT)

               QUIT

           IF '$GET(ORIT)

               QUIT

 +7        SET ORIDT=0

FOR

               SET ORIDT=$ORDER(^OR(100,"AOI",+ORIT,ORVP,ORIDT))

               IF ORIDT'>0

                   QUIT

               Begin DoDot:1

 +8                SET ORIFN=0

FOR

                       SET ORIFN=$ORDER(^OR(100,"AOI",+ORIT,ORVP,ORIDT,ORIFN))

                       IF ORIFN'>0

                           QUIT

                       Begin DoDot:2

 +9                        SET OR0=$GET(^OR(100,+ORIFN,0))

                           SET OR3=$GET(^(3))

                           SET ORSTS=+$PIECE(OR3,U,3)

 +10      ;return only latest order per status

                           IF ORSTS'>0

                               QUIT

                           IF $GET(ORY(ORSTS))

                               QUIT

 +11                       SET ORSTSNM=$$LOW^XLFSTR($PIECE($GET(^ORD(100.01,ORSTS,0)),U))

 +12                       SET ORY=ORY+1

                           SET ORY(ORSTS)=ORIFN_U_$PIECE(OR0,U,4)_U_$PIECE(OR0,U,7,10)_U_ORSTSNM

                       End DoDot:2

               End DoDot:1

 +13       QUIT

 +14      ;

DELAYED(ORY,ORDER) ; -- Return delayed order(s) with same OrdItem as ORDER

 +1       ;    in ORY(ORIFN) = PatEventPtr ^ EventName

 +2       ;

 +3        NEW ORI,ORIT,ORIFN

           SET (ORY,ORI)=0

 +4        FOR

               SET ORI=$ORDER(^OR(100,+ORDER,.1,ORI))

               IF ORI'>0

                   QUIT

               SET ORIT=+$GET(^(ORI,0))

               Begin DoDot:1

 +5       ;pending events

                   SET EVT=0

FOR

                       SET EVT=$ORDER(^ORE(100.2,"AE",+ORVP,EVT))

                       IF EVT<1

                           QUIT

                       SET PTEVT=+$ORDER(^(EVT,0))

                       Begin DoDot:2

 +6       ;delayed orders

                           SET ORIFN=0

FOR

                               SET ORIFN=+$ORDER(^OR(100,"AEVNT",ORVP,PTEVT,ORIFN))

                               IF ORIFN<1

                                   QUIT

                               Begin DoDot:3

 +7                                IF ORIFN=+ORDER

                                       QUIT

                                   IF '$DATA(^OR(100,ORIFN,.1,"B",ORIT))

                                       QUIT

 +8       ;terminated

                                   IF "^1^2^7^12^13^14^"[(U_$PIECE($GET(^OR(100,ORIFN,3)),U,3)_U)

                                       QUIT

 +9                                SET ORY=ORY+1

                                   SET ORY(ORIFN)=PTEVT_U_$PIECE($GET(^ORD(100.5,EVT,0)),U)

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +10       QUIT

 +11      ;

PKGID(ORIFN) ; -- Return package identifier for order ORIFN  [DBIA#3071]

 +1        QUIT $GET(^OR(100,+$GET(ORIFN),4))

 +2       ;

ES(ORDER) ; -- Returns the signature status of ORDER [DBIA#3632]

 +1       ;  -1 = invalid order#

 +2       ;  "" = no signature required

 +3       ;   0 = not signed (needs ES)

 +4       ;   1 = electronically or digitally signed

 +5       ;   2 = signed on chart

 +6       ;   3 = corrected or canceled order

 +7        NEW X,Y,DA

           IF '$GET(ORDER)!'$DATA(^OR(100,+$GET(ORDER),0))

               QUIT -1

 +8        SET DA=+$PIECE(ORDER,";",2)

           IF DA<1

               SET DA=+$PIECE($GET(^OR(100,+ORDER,3)),U,7)

 +9        SET X=$PIECE($GET(^OR(100,+ORDER,8,DA,0)),U,4)

 +10       SET Y=$SELECT(X=2:0,X=1!(X=7):1,X=0!(X=4):2,X=5!(X=6):3,1:"")

 +11       QUIT Y

 +12      ;

AND(DAD)  ; -- Return 1 or 0, if all conjunctions are AND [DBIA#3632]

 +1        NEW I,Y

           SET I=0

           SET Y=1

 +2        FOR

               SET I=+$ORDER(^OR(100,+$GET(DAD),4.5,"ID","CONJ",I))

               IF I<1

                   QUIT

               IF $EXTRACT($GET(^OR(100,+$GET(DAD),4.5,I,1)))'="A"

                   SET Y=0

                   QUIT

 +3        QUIT Y

ORX8.m