ORQ2.m

ORQ2 ; SLC/MKB/GSS - Detailed Order Report ;Aug 9, 2021@13:40:01

 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**12,56,75,94,141,213,195,243,282,293,280,346,361,471,453,405**;Dec 17, 1997;Build 211

 ;

 ;

 ;Reference to ^DIC(45.7 supported by IA #519

 ;Reference to OERR^VADPT supported by IA #4325

 ;Reference to CODECS^ICDEX supported by ICR #5747

 ;

DETAIL(ORY,ORIFN) ; -- Returns details of order ORIFN in ORY(#)

 N X,X2,I,CNT,ORDIALOG,OR0,OR3,OR6,SEQ,ITEM,PRMT,MULT,FIRST,TITLE,INST,DIWL,DIWR,DIWF,ACTION,VAIN,ORIGVIEW,ORNMSP,ORYT,ORCRACT

 N ORTRANS   ; OR*3*453 rbd Var needed for ORDER TRANSFERS logic below

 ; p 471 added ORCACT to use action if passed in

 S CNT=0,ORCRACT=+$P(ORIFN,";",2),ORIFN=+ORIFN,OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3)),OR6=$G(^(6))

 S ORNMSP=$$NMSP^ORCD($P(OR0,U,14))

 ; p 471 if no action, default to CURRENT ACTION..or if not $O(<The action subfile>, -1)

 S:'ORCRACT ORCRACT=$S(+$P(OR3,U,7):+$P(OR3,U,7),1:+$O(^OR(100,ORIFN,8,":"),-1))

 K @ORY,ORYT S ORIGVIEW=1 D TEXT^ORQ12(.ORYT,+ORIFN_";"_ORCRACT,80) ;CurrTx

 M @ORY=ORYT ;Move text to global

 S I=0 F CNT=1:1 S I=$O(ORYT(I)) Q:I'>0  D:$D(IORVON) SETVIDEO(I,1,$L(ORYT(I)),IORVON,IORVOFF)

 S CNT=CNT+1,@ORY@(CNT)="   " ;blank

D1 I $O(^OR(100,+ORIFN,2,0)) D

 . S CNT=CNT+1,@ORY@(CNT)="Sub Orders:"

 . D:$D(IOUON) SETVIDEO(CNT,1,11,IOUON,IOUOFF)

 . N IFN S IFN=0

 . F  S IFN=+$O(^OR(100,+ORIFN,2,IFN)) Q:IFN<1  I $D(^OR(100,IFN,0)) D SUB(IFN)

 . S CNT=CNT+1,@ORY@(CNT)="   " ;blank

 I $P(OR3,U,9),$D(^OR(100,+$P(OR3,U,9),0)) D

 . S CNT=CNT+1,@ORY@(CNT)="Parent Order:"

 . D:$D(IOUON) SETVIDEO(CNT,1,12,IOUON,IOUOFF)

 . D SUB(+$P(OR3,U,9))

 . S CNT=CNT+1,@ORY@(CNT)="   " ;blank

 I $P(OR3,U,11)=1,$P(OR3,U,5) D  ;Changed - show previous order

 . S CNT=CNT+1,@ORY@(CNT)="Previous Order:"

 . D:$D(IOUON) SETVIDEO(CNT,1,15,IOUON,IOUOFF) ;prev order original text

 . N ORZ,I,ORIGVIEW S ORIGVIEW=2 D TEXT^ORQ12(.ORZ,+$P(OR3,U,5),55)

 . S CNT=CNT+1,@ORY@(CNT)="     Order Text:        "_$G(ORZ(1))

 . S I=1 F  S I=$O(ORZ(I)) Q:I'>0  S CNT=CNT+1,@ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$G(ORZ(I))

D2 S CNT=CNT+1,@ORY@(CNT)="Activity:"

 D:$D(IOUON) SETVIDEO(CNT,1,9,IOUON,IOUOFF)

 S DIWL=1,DIWR=64,DIWF="C64",ORI=0 K ^UTILITY($J,"W")

 F  S ORI=$O(^OR(100,ORIFN,8,ORI)) Q:ORI'>0  S ACTION=$G(^(ORI,0)) D ACT^ORQ20

 ; RBD OR*3.0*453 Add ORDER TRANSFERS information

 S ORI=0 F  S ORI=$O(^OR(100,ORIFN,11,ORI)) Q:ORI'>0  D

 . I ORI=1 D

 .. S CNT=CNT+1,@ORY@(CNT)="   ",CNT=CNT+1,@ORY@(CNT)="Reassignments (Transfers):"

 . S ORTRANS=$G(^OR(100,ORIFN,11,ORI,0))

 . S CNT=CNT+1,@ORY@(CNT)="Transferred from "_$$USER^ORQ20($P(ORTRANS,U,2))_" to "_$$USER^ORQ20($P(ORTRANS,U,3))

 . S CNT=CNT+1,@ORY@(CNT)="  by "_$$USER^ORQ20($P(ORTRANS,U,4))_" Effective From "_$$DATE^ORQ20($P(ORTRANS,U))

 I $D(^OR(100,ORIFN,11)) S CNT=CNT+1,@ORY@(CNT)="   "

 I "^1^12^13^"[(U_$P(OR3,U,3)_U),$L(OR6),$P(ACTION,U,2)'="DC" D DC^ORQ20

 I $P(OR3,U,3)=2,$P(OR6,U,6) S CNT=CNT+1,@ORY@(CNT)=$$DATE^ORQ20($P(OR6,U,6))_"  Completed"_$S($P(OR6,U,7):" by "_$$USER^ORQ20($P(OR6,U,7)),1:"")

 S CNT=CNT+1,@ORY@(CNT)="   " ;blank

D3 S CNT=CNT+1,@ORY@(CNT)="Current Data:"

 D:$D(IOUON) SETVIDEO(CNT,1,13,IOUON,IOUOFF)

 D VA I $G(VAIN(2)) S CNT=CNT+1,@ORY@(CNT)="Current Primary Provider:     "_$P(VAIN(2),"^",2)

 I $G(VAIN(11)) S CNT=CNT+1,@ORY@(CNT)="Current Attending Physician:  "_$P(VAIN(11),"^",2)

 S CNT=CNT+1,@ORY@(CNT)="Treating Specialty:           "_$P($G(^DIC(45.7,+$P(OR0,U,13),0)),U)

 S CNT=CNT+1,@ORY@(CNT)="Ordering Location:            "_$P($G(^SC(+$P(OR0,U,10),0)),U)

 S CNT=CNT+1,@ORY@(CNT)="Start Date/Time:              "_$S($P(OR0,U,8):$$DATE^ORQ20($P(OR0,U,8)),1:"")

 I $P(OR3,U,5),$P(OR3,U,11)=2 S X=$$ORIG(ORIFN),@ORY@(CNT)=@ORY@(CNT)_" (originally "_$$DATE^ORQ20(X)_")"

 S CNT=CNT+1,@ORY@(CNT)="Stop Date/Time:               "_$S($P(OR0,U,9):$$DATE^ORQ20($P(OR0,U,9)),1:"")

 I $P(OR3,U,3)=1,$P(OR6,U,6) S @ORY@(CNT)=@ORY@(CNT)_"  (expired "_$$DATE^ORQ20($P(OR6,U,6))_")"

 S CNT=CNT+1,@ORY@(CNT)="Current Status:               "_$S($D(^ORD(100.01,+$P(OR3,U,3),0)):$P(^(0),"^"),1:"-")

 I $$GET^XPAR("ALL","ORPF SHOW STATUS DESCRIPTION",1,"I"),$P(OR3,U,3),$D(^ORD(100.01,$P(OR3,U,3),0)) N J S J=0 F  S J=$O(^ORD(100.01,$P(OR3,U,3),1,J)) Q:J<1  S CNT=CNT+1,@ORY@(CNT)="  "_^(J,0)

 S CNT=CNT+1,@ORY@(CNT)="Order #"_ORIFN

 S CNT=CNT+1,@ORY@(CNT)="   " ;blank

D4 S CNT=CNT+1,@ORY@(CNT)="Order:" D:$D(IOUON) SETVIDEO(CNT,1,6,IOUON,IOUOFF)

 I '$O(^OR(100,ORIFN,4.5,0)),ORNMSP="RA" D RAD^ORQ21("") Q

 S ORDIALOG=$P(OR0,U,5) Q:$P(ORDIALOG,";",2)="ORD(101,"  ; 2.5 order

 D GETDLG^ORCD(+ORDIALOG),GETORDER^ORCD(ORIFN)

 I ORNMSP="GMRC" D GMRCXTRA

 S DIWL=1,DIWR=50,DIWF="C50"

 S SEQ=0 F  S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ)) Q:SEQ'>0  S DA=0 F  S DA=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ,DA)) Q:'DA  D

 . S ITEM=$G(^ORD(101.41,+ORDIALOG,10,DA,0)) Q:$P(ITEM,U,11)  ; child

 . S PRMT=$P(ITEM,U,2),MULT=$P(ITEM,U,7) Q:$P(ITEM,U,9)["*"  ;hide

 . S FIRST=$O(ORDIALOG(PRMT,0)) Q:'FIRST  ; no values

 . S TITLE=$S(MULT&$L($G(ORDIALOG(PRMT,"TTL"))):ORDIALOG(PRMT,"TTL"),1:ORDIALOG(PRMT,"A"))

 . S TITLE=TITLE_$$REPEAT^XLFSTR(" ",30-$L(TITLE))

 . S INST=0 F  S INST=$O(ORDIALOG(PRMT,INST)) Q:INST'>0  D

 . . I $E(ORDIALOG(PRMT,0))="W" D WP Q

 . . K ^UTILITY($J,"W") S X=$$EXT^ORCD(PRMT,INST) I TITLE["Infusion Rate"&(X'="")&(X'["ml/hr") S TITLE="Infuse Over Time:",TITLE=TITLE_$$REPEAT^XLFSTR(" ",30-$L(TITLE))

 . . D ^DIWP

 . . D:$D(^ORD(101.41,+ORDIALOG,10,"DAD",PRMT)) CHILDREN(PRMT)

 . . S I=0 F  S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0  S CNT=CNT+1,@ORY@(CNT)=$S((INST=FIRST)&(I=1):TITLE,1:$$REPEAT^XLFSTR(" ",30))_^(I,0)

 I ORNMSP="GMRC",$G(^OR(100,ORIFN,4)) S CNT=CNT+1,@ORY@(CNT)="Consult No.:                  "_+^(4)

 S CNT=CNT+1,@ORY@(CNT)="   " ;blank

 D RAD^ORQ21(1):ORNMSP="RA",MED^ORQ21:ORNMSP="PS" ;add'l data

 D BA^ORQ21 ;call for CIDC data

D5 K ^TMP($J,"OCDATA") I $$OCAPI^ORCHECK(+ORIFN,"OCDATA") D

 . N CK,OK,X0,X,CDL,I,ACK,ALLGYDRG,HDR S HDR=0

 . D:$D(IOUON) SETVIDEO(CNT,1,13,IOUON,IOUOFF)

 . S ACK=0

 . D ALLERGY         ;405

 . S:$D(OK) OK=""    ;405

 . S CK=0 F  S CK=$O(^TMP($J,"OCDATA",CK)) Q:CK'>0  D

 .. Q:$D(ALLGYDRG(CK))  ;405

 .. S:HDR=0 CNT=CNT+1,@ORY@(CNT)=" ",CNT=CNT+1,@ORY@(CNT)="Order Checks:",HDR=1

 .. S X0=^TMP($J,"OCDATA",CK,"OC NUMBER")_U_^TMP($J,"OCDATA",CK,"OC LEVEL")_U_U_^TMP($J,"OCDATA",CK,"OR REASON")_U_^TMP($J,"OCDATA",CK,"OR PROVIDER")_U_^TMP($J,"OCDATA",CK,"OR DT")

 .. S X=^TMP($J,"OCDATA",CK,"OC TEXT",1,0)

 .. S CDL=$$CDL($P(X0,U,2)) I $P(X0,U,6),'$D(OK) S OK=$P(X0,U,4,6)

 .. I $L(X)'>68 S CNT=CNT+1,@ORY@(CNT)=CDL_X D XTRA Q

 .. S DIWL=1,DIWR=68,DIWF="C68" K ^UTILITY($J,"W") D ^DIWP

 .. S I=0 F  S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0  S CNT=CNT+1,@ORY@(CNT)=CDL_^(I,0),CDL="            "

 .. D XTRA

 . K ^TMP($J,"OCDATA")

 . Q:(HDR=0)     ;405 quit if only allergy-drug interactions

 . Q:'$L($G(OK))  S CNT=CNT+1,@ORY@(CNT)="Override:   "_$S($P(OK,U,2):$$USER^ORQ20($P(OK,U,2))_" on ",1:"")_$$DATE^ORQ20($P(OK,U,3))

 . I $L($P(OK,U))'>68 S CNT=CNT+1,@ORY@(CNT)="            "_$P(OK,U) Q

 . S DIWL=1,DIWR=68,DIWF="C68",X=$P(OK,U) K ^UTILITY($J,"W") D ^DIWP

 . S I=0 F  S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0  S CNT=CNT+1,@ORY@(CNT)="            "_^(I,0)

 K ^TMP("ORWORD",$J),^UTILITY($J,"W"),ALLGYDRG

 Q

 ;

XTRA ;

 I $O(^TMP($J,"OCDATA",CK,"OC TEXT",1)) N ORXT S ORXT=1 F  S ORXT=$O(^TMP($J,"OCDATA",CK,"OC TEXT",ORXT)) Q:'ORXT  D

 . S X=^TMP($J,"OCDATA",CK,"OC TEXT",ORXT,0),CDL="              "

 . I $L(X)'>68 S CNT=CNT+1,@ORY@(CNT)=CDL_X Q

 . S DIWL=1,DIWR=68,DIWF="C68" K ^UTILITY($J,"W") D ^DIWP

 . S I=0 F  S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0  S CNT=CNT+1,@ORY@(CNT)=CDL_^(I,0),CDL="              "

 I $O(^TMP($J,"OCDATA",CK,"OC TEXT",1)) S X="",CNT=CNT+1,@ORY@(CNT)="              "

 Q

 ;

SUB(IFN) ; -- add suborder or parent

 N ORCY,STS,STRT,IG,A,STOP,SCHED D TEXT^ORQ12(.ORCY,IFN,58)

 S STS=$G(^ORD(100.01,+$P($G(^OR(100,IFN,3)),U,3),.1))

 S A=^OR(100,IFN,0),STRT=$P(A,U,8),STOP=$P(A,U,9)

 S SCHED=$$VALUE^ORX8(IFN,"SCHEDULE",1,"E")

 S:STRT'="" STRT=$$DATE^ORQ20(STRT) I ORNMSP="LR" S:STOP]"" STOP=$$DATE^ORQ20(STOP)

 S IG=0 F  S IG=$O(ORCY(IG)) Q:IG<1  S CNT=CNT+1,@ORY@(CNT)=$J(STS,4)_" "_ORCY(IG)_" "_STRT,(STS,STRT)=" "

 I ORNMSP="LR",STOP]"" S CNT=CNT+1,@ORY@(CNT)=$J("How often: ",16)_SCHED_"   Stops:  "_STOP

 Q

 ;

WP ; -- add word-processing

 N WP,ORI,X M WP=@ORDIALOG(PRMT,INST)

 S CNT=CNT+1,@ORY@(CNT)=TITLE

 S ORI=0 F  S ORI=$O(WP(ORI)) Q:ORI'>0  S X=WP(ORI,0) S:X'="" CNT=CNT+1,@ORY@(CNT)="  "_X

 Q

 ;

CHILDREN(PARENT) ; -- add children

 N SEQ,DA,ITM,PRMT,TYPE,X

 S SEQ=0 F  S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PARENT,SEQ)) Q:SEQ'>0  S DA=$O(^(SEQ,0)) D

 . S ITM=$G(^ORD(101.41,+ORDIALOG,10,DA,0)),PRMT=$P(ITM,U,2)

 . Q:$G(ORDIALOG(PRMT,INST))=""  Q:$P(ITM,U,9)["*"  ;no value or hide

 . S TYPE=$E(ORDIALOG(PRMT,0)) D:TYPE="W" WP

 . I TYPE'="W" D

 . . S X=$$EXT^ORCD(PRMT,INST)

 . . I $L(X,"|")=2 S X=$$REPLACE^ORHLESC(X,"|","||")

 . . D ^DIWP

 Q

 ;

SETVIDEO(LINE,COL,WIDTH,ON,OFF) ; -- set video attributes

 S ORY("VIDEO",LINE,COL,WIDTH)=ON

 S ORY("VIDEO",LINE,COL+WIDTH,0)=OFF

 Q

 ;

VA ; -- Call VADPT

 N ORY,DFN,Y S DFN=+$P(OR0,"^",2) D OERR^VADPT

 Q

 ;

CDL(X) ; -- Returns Clinical Danger Level X

 N Y S Y=$S(X=1:"HIGH:",X=2:"MODERATE:",X=3:"LOW:",1:"NONE:")

 S Y=$E(Y_"        ",1,12)

 Q Y

 ;

ORIG(IFN) ; -- Return original start date of [renewal] order

 N I,Y,X3,DONE

 S I=IFN,Y=$P($G(^OR(100,IFN,0)),U,8),DONE=0

 F  S X3=$G(^OR(100,I,3)) D  Q:DONE

 . I $P(X3,U,11)=2,$P(X3,U,5) S I=$P(X3,U,5) Q  ;loop

 . S Y=$P($G(^OR(100,I,0)),U,8),DONE=1

 Q Y

GMRCXTRA ; expects ORDIALOG to be populated and ORIFN to be present

 N ORGMROUT,ORDGDA,ORGMRICD,ORCODE,ORISCODE,ORCODSYS

 I '$G(^OR(100,ORIFN,4)) D

 . S ORISCODE=ORDIALOG("B","CODE"),ORISCODE=$P(ORISCODE,U,2)

  . I +$G(ORISCODE)>0 D

  .. Q:'$D(ORDIALOG(ORISCODE,1))

  .. S ORCODE=ORDIALOG(ORISCODE,1)

  .. S ORCODSYS=$$CODECS^ICDEX(ORCODE,"80")

  .. S ORGMROUT=$P($G(ORCODSYS),U,2)

 I $G(^OR(100,ORIFN,4)) D

 . S ORGMROUT="ICD-9-CM"

 . Q:'$D(^GMR(123,+^OR(100,+ORIFN,4),30.1))

 . S ORGMRICD=^GMR(123,+^OR(100,+ORIFN,4),30.1)

 . I $P(ORGMRICD,U,3)="10D" S ORGMROUT="ICD-10-CM"

 S ORDGDA=$G(ORDIALOG("B","CODE"))

 Q:'$P(ORDGDA,U,2)

 S ORDGDA=$P(ORDGDA,U,2)

 Q:'$D(ORDIALOG(ORDGDA,1))

 S ORDIALOG(ORDGDA,1)="("_ORGMROUT_" "_ORDIALOG(ORDGDA,1)_")"

 Q

ALLERGY ;separate the ALLERGY-DRUG INTERACTION Order Checks (405)

 N ORRET,ORINSTAN,ORSAVINS

 S ORRET=1

 S (ACK,CK)=0 F  S CK=$O(^TMP($J,"OCDATA",CK)) Q:CK'>0  D

 . I $G(^TMP($J,"OCDATA",CK,"OC NUMBER"))'=3 Q

 . S ALLGYDRG(CK)=" "

 . I ACK=0 S CNT=CNT+1,@ORY@(CNT)=" ",CNT=CNT+1,@ORY@(CNT)="Allergy Order Checks:",CNT=CNT+1,ACK=1

 . S X0=^TMP($J,"OCDATA",CK,"OC NUMBER")_U_^TMP($J,"OCDATA",CK,"OC LEVEL")_U_U_^TMP($J,"OCDATA",CK,"OR REASON")_U_^TMP($J,"OCDATA",CK,"OR PROVIDER")_U_^TMP($J,"OCDATA",CK,"OR DT")

 . S X=^TMP($J,"OCDATA",CK,"OC TEXT",1,0)

 . S CDL=$$CDL($P(X0,U,2)) I $P(X0,U,6),'$D(OK) S OK=$P(X0,U,4,6)

 . I $L(X)'>68 S CNT=CNT+1,@ORY@(CNT)=CDL_X D XTRA Q

 . S DIWL=1,DIWR=68,DIWF="C68" K ^UTILITY($J,"W") D ^DIWP

 . S I=0 F  S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0  S CNT=CNT+1,@ORY@(CNT)=CDL_^UTILITY($J,"W",DIWL,I,0),CDL="            "

 . S ORINSTAN=$G(^TMP($J,"OCDATA",CK,"OC INSTANCE"))

 . I ORINSTAN>0  D

 .. I $$GET1^DIQ(100.517,ORRET_","_ORINSTAN_",",11)'=""  D

 ... S:'$D(ORSAVINS) ORSAVINS=ORINSTAN

 . D XTRA

 I ACK=1  D

 . Q:'$L($G(OK))  S CNT=CNT+1,@ORY@(CNT)="Override:   "_$S($P(OK,U,2):$$USER^ORQ20($P(OK,U,2))_" on ",1:"")_$$DATE^ORQ20($P(OK,U,3))

 . I $L($P(OK,U))'>68 S CNT=CNT+1,@ORY@(CNT)="            "_$P(OK,U),CNT=CNT+1 Q

 . S DIWL=1,DIWR=68,DIWF="C68",X=$P(OK,U) K ^UTILITY($J,"W") D ^DIWP

 . S I=0 F  S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0  S CNT=CNT+1,@ORY@(CNT)="            "_^UTILITY($J,"W",DIWL,I,0)

 I $D(ORSAVINS)  D

 . S CNT=CNT+1,@ORY@(CNT)="            "

 . S CNT=CNT+1,@ORY@(CNT)="Remote Comment: "_$$GET1^DIQ(100.517,ORRET_","_ORSAVINS_",",11)

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---ORQ2   12027     printed  Feb 18, 2025@23:59:41                                                                                                                                                                                                       Page 2

ORQ2      ; SLC/MKB/GSS - Detailed Order Report ;Aug 9, 2021@13:40:01

 +1       ;;3.0;ORDER ENTRY/RESULTS REPORTING;**12,56,75,94,141,213,195,243,282,293,280,346,361,471,453,405**;Dec 17, 1997;Build 211

 +2       ;

 +3       ;

 +4       ;Reference to ^DIC(45.7 supported by IA #519

 +5       ;Reference to OERR^VADPT supported by IA #4325

 +6       ;Reference to CODECS^ICDEX supported by ICR #5747

 +7       ;

DETAIL(ORY,ORIFN) ; -- Returns details of order ORIFN in ORY(#)

 +1        NEW X,X2,I,CNT,ORDIALOG,OR0,OR3,OR6,SEQ,ITEM,PRMT,MULT,FIRST,TITLE,INST,DIWL,DIWR,DIWF,ACTION,VAIN,ORIGVIEW,ORNMSP,ORYT,ORCRACT

 +2       ; OR*3*453 rbd Var needed for ORDER TRANSFERS logic below

           NEW ORTRANS

 +3       ; p 471 added ORCACT to use action if passed in

 +4        SET CNT=0

           SET ORCRACT=+$PIECE(ORIFN,";",2)

           SET ORIFN=+ORIFN

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

           SET OR3=$GET(^(3))

           SET OR6=$GET(^(6))

 +5        SET ORNMSP=$$NMSP^ORCD($PIECE(OR0,U,14))

 +6       ; p 471 if no action, default to CURRENT ACTION..or if not $O(<The action subfile>, -1)

 +7        if 'ORCRACT

               SET ORCRACT=$SELECT(+$PIECE(OR3,U,7):+$PIECE(OR3,U,7),1:+$ORDER(^OR(100,ORIFN,8,":"),-1))

 +8       ;CurrTx

           KILL @ORY,ORYT

           SET ORIGVIEW=1

           DO TEXT^ORQ12(.ORYT,+ORIFN_";"_ORCRACT,80)

 +9       ;Move text to global

           MERGE @ORY=ORYT

 +10       SET I=0

           FOR CNT=1:1

               SET I=$ORDER(ORYT(I))

               if I'>0

                   QUIT 

               if $DATA(IORVON)

                   DO SETVIDEO(I,1,$LENGTH(ORYT(I)),IORVON,IORVOFF)

 +11      ;blank

           SET CNT=CNT+1

           SET @ORY@(CNT)="   "

D1         IF $ORDER(^OR(100,+ORIFN,2,0))

               Begin DoDot:1

 +1                SET CNT=CNT+1

                   SET @ORY@(CNT)="Sub Orders:"

 +2                if $DATA(IOUON)

                       DO SETVIDEO(CNT,1,11,IOUON,IOUOFF)

 +3                NEW IFN

                   SET IFN=0

 +4                FOR 

                       SET IFN=+$ORDER(^OR(100,+ORIFN,2,IFN))

                       if IFN<1

                           QUIT 

                       IF $DATA(^OR(100,IFN,0))

                           DO SUB(IFN)

 +5       ;blank

                   SET CNT=CNT+1

                   SET @ORY@(CNT)="   "

               End DoDot:1

 +6        IF $PIECE(OR3,U,9)

               IF $DATA(^OR(100,+$PIECE(OR3,U,9),0))

                   Begin DoDot:1

 +7                    SET CNT=CNT+1

                       SET @ORY@(CNT)="Parent Order:"

 +8                    if $DATA(IOUON)

                           DO SETVIDEO(CNT,1,12,IOUON,IOUOFF)

 +9                    DO SUB(+$PIECE(OR3,U,9))

 +10      ;blank

                       SET CNT=CNT+1

                       SET @ORY@(CNT)="   "

                   End DoDot:1

 +11      ;Changed - show previous order

           IF $PIECE(OR3,U,11)=1

               IF $PIECE(OR3,U,5)

                   Begin DoDot:1

 +12                   SET CNT=CNT+1

                       SET @ORY@(CNT)="Previous Order:"

 +13      ;prev order original text

                       if $DATA(IOUON)

                           DO SETVIDEO(CNT,1,15,IOUON,IOUOFF)

 +14                   NEW ORZ,I,ORIGVIEW

                       SET ORIGVIEW=2

                       DO TEXT^ORQ12(.ORZ,+$PIECE(OR3,U,5),55)

 +15                   SET CNT=CNT+1

                       SET @ORY@(CNT)="     Order Text:        "_$GET(ORZ(1))

 +16                   SET I=1

                       FOR 

                           SET I=$ORDER(ORZ(I))

                           if I'>0

                               QUIT 

                           SET CNT=CNT+1

                           SET @ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$GET(ORZ(I))

                   End DoDot:1

D2         SET CNT=CNT+1

           SET @ORY@(CNT)="Activity:"

 +1        if $DATA(IOUON)

               DO SETVIDEO(CNT,1,9,IOUON,IOUOFF)

 +2        SET DIWL=1

           SET DIWR=64

           SET DIWF="C64"

           SET ORI=0

           KILL ^UTILITY($JOB,"W")

 +3        FOR 

               SET ORI=$ORDER(^OR(100,ORIFN,8,ORI))

               if ORI'>0

                   QUIT 

               SET ACTION=$GET(^(ORI,0))

               DO ACT^ORQ20

 +4       ; RBD OR*3.0*453 Add ORDER TRANSFERS information

 +5        SET ORI=0

           FOR 

               SET ORI=$ORDER(^OR(100,ORIFN,11,ORI))

               if ORI'>0

                   QUIT 

               Begin DoDot:1

 +6                IF ORI=1

                       Begin DoDot:2

 +7                        SET CNT=CNT+1

                           SET @ORY@(CNT)="   "

                           SET CNT=CNT+1

                           SET @ORY@(CNT)="Reassignments (Transfers):"

                       End DoDot:2

 +8                SET ORTRANS=$GET(^OR(100,ORIFN,11,ORI,0))

 +9                SET CNT=CNT+1

                   SET @ORY@(CNT)="Transferred from "_$$USER^ORQ20($PIECE(ORTRANS,U,2))_" to "_$$USER^ORQ20($PIECE(ORTRANS,U,3))

 +10               SET CNT=CNT+1

                   SET @ORY@(CNT)="  by "_$$USER^ORQ20($PIECE(ORTRANS,U,4))_" Effective From "_$$DATE^ORQ20($PIECE(ORTRANS,U))

               End DoDot:1

 +11       IF $DATA(^OR(100,ORIFN,11))

               SET CNT=CNT+1

               SET @ORY@(CNT)="   "

 +12       IF "^1^12^13^"[(U_$PIECE(OR3,U,3)_U)

               IF $LENGTH(OR6)

                   IF $PIECE(ACTION,U,2)'="DC"

                       DO DC^ORQ20

 +13       IF $PIECE(OR3,U,3)=2

               IF $PIECE(OR6,U,6)

                   SET CNT=CNT+1

                   SET @ORY@(CNT)=$$DATE^ORQ20($PIECE(OR6,U,6))_"  Completed"_$SELECT($PIECE(OR6,U,7):" by "_$$USER^ORQ20($PIECE(OR6,U,7)),1:"")

 +14      ;blank

           SET CNT=CNT+1

           SET @ORY@(CNT)="   "

D3         SET CNT=CNT+1

           SET @ORY@(CNT)="Current Data:"

 +1        if $DATA(IOUON)

               DO SETVIDEO(CNT,1,13,IOUON,IOUOFF)

 +2        DO VA

           IF $GET(VAIN(2))

               SET CNT=CNT+1

               SET @ORY@(CNT)="Current Primary Provider:     "_$PIECE(VAIN(2),"^",2)

 +3        IF $GET(VAIN(11))

               SET CNT=CNT+1

               SET @ORY@(CNT)="Current Attending Physician:  "_$PIECE(VAIN(11),"^",2)

 +4        SET CNT=CNT+1

           SET @ORY@(CNT)="Treating Specialty:           "_$PIECE($GET(^DIC(45.7,+$PIECE(OR0,U,13),0)),U)

 +5        SET CNT=CNT+1

           SET @ORY@(CNT)="Ordering Location:            "_$PIECE($GET(^SC(+$PIECE(OR0,U,10),0)),U)

 +6        SET CNT=CNT+1

           SET @ORY@(CNT)="Start Date/Time:              "_$SELECT($PIECE(OR0,U,8):$$DATE^ORQ20($PIECE(OR0,U,8)),1:"")

 +7        IF $PIECE(OR3,U,5)

               IF $PIECE(OR3,U,11)=2

                   SET X=$$ORIG(ORIFN)

                   SET @ORY@(CNT)=@ORY@(CNT)_" (originally "_$$DATE^ORQ20(X)_")"

 +8        SET CNT=CNT+1

           SET @ORY@(CNT)="Stop Date/Time:               "_$SELECT($PIECE(OR0,U,9):$$DATE^ORQ20($PIECE(OR0,U,9)),1:"")

 +9        IF $PIECE(OR3,U,3)=1

               IF $PIECE(OR6,U,6)

                   SET @ORY@(CNT)=@ORY@(CNT)_"  (expired "_$$DATE^ORQ20($PIECE(OR6,U,6))_")"

 +10       SET CNT=CNT+1

           SET @ORY@(CNT)="Current Status:               "_$SELECT($DATA(^ORD(100.01,+$PIECE(OR3,U,3),0)):$PIECE(^(0),"^"),1:"-")

 +11       IF $$GET^XPAR("ALL","ORPF SHOW STATUS DESCRIPTION",1,"I")

               IF $PIECE(OR3,U,3)

                   IF $DATA(^ORD(100.01,$PIECE(OR3,U,3),0))

                       NEW J

                       SET J=0

                       FOR 

                           SET J=$ORDER(^ORD(100.01,$PIECE(OR3,U,3),1,J))

                           if J<1

                               QUIT 

                           SET CNT=CNT+1

                           SET @ORY@(CNT)="  "_^(J,0)

 +12       SET CNT=CNT+1

           SET @ORY@(CNT)="Order #"_ORIFN

 +13      ;blank

           SET CNT=CNT+1

           SET @ORY@(CNT)="   "

D4         SET CNT=CNT+1

           SET @ORY@(CNT)="Order:"

           if $DATA(IOUON)

               DO SETVIDEO(CNT,1,6,IOUON,IOUOFF)

 +1        IF '$ORDER(^OR(100,ORIFN,4.5,0))

               IF ORNMSP="RA"

                   DO RAD^ORQ21("")

                   QUIT 

 +2       ; 2.5 order

           SET ORDIALOG=$PIECE(OR0,U,5)

           if $PIECE(ORDIALOG,";",2)="ORD(101,"

               QUIT 

 +3        DO GETDLG^ORCD(+ORDIALOG)

           DO GETORDER^ORCD(ORIFN)

 +4        IF ORNMSP="GMRC"

               DO GMRCXTRA

 +5        SET DIWL=1

           SET DIWR=50