ORB31 ; slc/CLA - Routine to support OE/RR 3 notifications ;06/27/17  07:14
 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**6,31,88,105,139,173,220,215,329,452**;Dec 17, 1997;Build 2
QUEUE(ORN,ORBDFN,ORNUM,ORBADUZ,ORBPMSG,ORBPDATA,ORBH,ORBD,ORDGPMA,ORFORCE) ;
 ;queue up notif for Taskman processing
 ;ORN       notification ien from file 100.9
 ;ORBDFN    patient dfn from file 2
 ;ORNUM     order number from file 100
 ;ORBADUZ   array of potential user recipients (iens from file 100)
 ;ORBPMSG   alert message from triggering process
 ;ORBPDATA  data potentially used in alert follow-up action
 ;ORBH      $H formatted time to begin Taskman process
 ;ORBD      process description for Taskman
 ;ORDGPMA   DGPMA if alert triggered by A/D/T event
 ;ORFORCE   set array of DUZs that should get alert even if not on
 ;
 N ZTCPU,ZTDESC,ZTDTH,ZTIO,ZTPAR,ZTPRE,ZTPRI,ZTREQ,ZTRTN,ZTSAVE,ZTSK,ZTUCI,X,Y,DIC
 ;
 S DIC="3.5",X="ORB NOTIFICATION RESOURCE",DIC(0)="X" D ^DIC
 I (Y) S ZTIO=$P(Y,U,2)
 E  S ZTIO=""
 S ZTDTH=ORBH,ZTRTN="ZTSK^ORB3"
 S ZTDESC=ORBD
 S ZTDESC=ZTDESC_"for ("_ORBDFN_") "_$P($G(^DPT(+ORBDFN,0)),U,1)
 K ZTSAVE,ZTCPU,ZTUCI,ZTPRI,ZTPAR,ZTPRE,DIC,Y,DTOUT,DUOUT
 ;
 S ZTSAVE("ORN")=""
 S ZTSAVE("ORBDFN")=""
 S ZTSAVE("ORNUM")=""
 S ZTSAVE("ORBADUZ(")=""
 S ZTSAVE("ORBPMSG")=""
 S ZTSAVE("ORBPDATA")=""
 S ZTSAVE("ORDGPMA")=""
 S ZTSAVE("ORFORCE(")=""
 D ^%ZTLOAD
 Q
DUP(ORN,ORBDFN,ORBPMSG,ORNUM) ;ext funct return "1" if a duplicate notif w/in 1 min.
 N ORBDUP,ORBNOW,ORBLAST,ORLNUM,ORSAMEP,ORSAMEREC
 S ORBDUP=0
 S ORSAMEP=0
 S ORBNOW=$$NOW^XLFDT
 S ^XTMP("ORBDUP",0)=$$FMADD^XLFDT(ORBNOW,1,"","","")_"^"_ORBNOW
 I '$L($G(^XTMP("ORBDUP",ORBDFN_";"_ORN_";"_ORBPMSG))) S ^XTMP("ORBDUP",ORBDFN_";"_ORN_";"_ORBPMSG)=ORBNOW_"^"_$G(ORNUM)
 E  D
 .S ORBLAST=$G(^XTMP("ORBDUP",ORBDFN_";"_ORN_";"_ORBPMSG))
 .S ORLNUM=$P(ORBLAST,"^",2)
 .S ORBLAST=$P(ORBLAST,"^")
 .I $L($G(ORNUM)),$L($G(ORLNUM)),($$ORDERER^ORQOR2(ORNUM)=$$ORDERER^ORQOR2(ORLNUM)) S ORSAMEP=1 ;same provider as last order that triggered this notif
 .S ORSAMEREC=1 I ORN=6,($$RECIP($G(ORNUM))'=$$RECIP($G(ORLNUM))) S ORSAMEREC=0
 .;if last occurrence of this "NOT" notif was w/in past 1 min, its a dup
 .I ORBNOW<$$FMADD^XLFDT(ORBLAST,"","",1,""),ORSAMEP=1,ORSAMEREC=1 S ORBDUP=1  ;dup
 .E  S ^XTMP("ORBDUP",ORBDFN_";"_ORN_";"_ORBPMSG)=ORBNOW_"^"_ORNUM  ;refresh last pt/noti occ.
 D DUPCLN(ORBNOW)  ;clean up old ^XTMP("ORBUP") entries
 Q ORBDUP
RECIP(ORNUM) N ORI,RECIP
 Q:'ORNUM 0
 S ORI=0 F  S ORI=$O(^OR(100,ORNUM,8,ORI)) Q:'ORI  D
 .I '$P($G(^OR(100,ORNUM,8,ORI,3)),U,6)&($P($G(^OR(100,ORNUM,8,ORI,3)),U,9)) S RECIP=$P($G(^OR(100,ORNUM,8,ORI,3)),U,9)
 Q $G(RECIP)
REGDEV(ORBDA) ;send to regular recipient devices
 N ORBDT,ORBD
 S ORBD=""
 S ORBDT=$$NOW^XLFDT
 F   S ORBD=$O(ORBDA(ORBD)) Q:ORBD=""  D
 .S ZTRTN="PRINTD^ORB31",ZTDESC="Print Notification to Device",ZTDTH=$H
 .S ZTIO=ORBD,ZTSAVE("XQAMSG")="",ZTSAVE("ORBDT")=""
 .D ^%ZTLOAD
 Q
PRINTD ;print queued notification to device - setup via REGDEV^ORB3
 I $G(ZTSK) D KILL^%ZTLOAD
 I IOT="HFS" W XQAMSG Q  ;write msg to a file then quit
 W !!!,"          ***** NOTIFICATION PROCESSED *****",!!
 W $$FMTE^XLFDT(ORBDT),"   "
 W XQAMSG
 I $E(IOST,1,2)'="C-" W @IOF
 Q
FWD(ORY,ORBLST,ORBRECIP,ORBTYPE,ORBCOMNT) ; forward a notification
 I ORBLST="" S ORY=0 Q
 S ORBLST(1)=ORBLST
 D FORWARD^XQALFWD(.ORBLST,.ORBRECIP,ORBTYPE,ORBCOMNT)
 S ORY=1
 Q
RENEW(ORY,XQAID) ; renew/restore an alert/notification
 Q:$L($G(XQAID))<1
 K XQAKILL
 I '$D(^XTV(8992,"AXQA",XQAID,DUZ)) D RESTORE^XQALERT1 ;DBIA #4100
 S ORY=1
 Q
TERMLKUP(OCXARR,OCXTERM) ; extrinsic function returns the local terms
 ; linked to the nat'l OCX term in an array and the file where those
 ; array terms can be found. The value of the extrinsic function is the
 ; file pointed to for the local terms.
 ;
 ; OCXARR  - Array of local terms
 ; OCXTERM - OCX nat'l term from file ^OCXS(860.9
 ;
 N OCXI,OCXJ,FILE,I
 S OCXI="",OCXJ=0,FILE="",I=1
 S OCXI=$O(^OCXS(860.9,"B",OCXTERM,OCXI))
 I +$G(OCXI)>0 D
 .S FILE=$P(^OCXS(860.9,OCXI,0),U,2)
 .F  S OCXJ=$O(^OCXS(860.9,OCXI,1,OCXJ)) Q:+OCXJ<1  D
 ..S OCXARR(I)=$P(^OCXS(860.9,OCXI,1,OCXJ,0),U,2)_U_$P(^(0),U)
 ..S OCXARR=I,I=I+1
 Q FILE
DUPCLN(ORBNOW) ;clean up old entires in ^XTMP("ORBDUP")
 N ORBX,ORBDT,ORNDT
 S ORNDT=$$FMADD^XLFDT(ORBNOW,"","",-5,"")  ;entries older than 5 minutes
 S ORBX=0
 F  S ORBX=$O(^XTMP("ORBDUP",ORBX)) Q:ORBX=""  D
 .S ORBDT=+$G(^XTMP("ORBDUP",ORBX))
 .I $L(ORBDT),(ORBDT<ORNDT) K ^XTMP("ORBDUP",ORBX)
 Q
TMDEV(ORBTM) ;returns Device for a team in format device ien^device name
 N ORBTDEV,ORBTDEVN
 S ORBTDEVN=""
 Q:'$L($G(ORBTM)) ""
 Q:'$D(^OR(100.21,ORBTM,0)) ""
 S ORBTDEV=$P(^OR(100.21,ORBTM,0),U,4)  ;get Team's device
 Q:+$G(ORBTDEV)<1 ""
 S X="`"_ORBTDEV,DIC=3.5,DIC(0)="" D ^DIC  ;DBIA #10114
 Q:+Y<1 ""
 S ORBTDEVN=$P(Y,U,2)
 K DIC,Y,X
 Q ORBTDEV_U_ORBTDEVN
ENTITY(ORNUM) ;ext funct. rtns entity for parameter use
 N ORBENT
 S ORBENT="DIV^SYS^PKG"
 I $L($G(ORNUM)) D  ;if order number use pt's location division
 .N ORDIV
 .S ORDIV=0,ORDIV=$$ORDIV(ORNUM)
 .I +$G(ORDIV)>0 S ORBENT=ORDIV_";DIC(4,^SYS^PKG"
 Q ORBENT
 ;
ADT(ORN,ORBDFN,ORBPRIM,ORBATTD,ORDGPMA) ;get inpt primary and attending for ADT notifs
 N ORBADTDT,VAINDT
 ;if notif is deceased or discharge use prev visit d/t:
 I (ORN=20)!(ORN=35) D
 .S ORBADTDT=$S($D(ORDGPMA):$P(ORDGPMA,U),1:$P($G(^DPT(ORBDFN,.35)),U))
 .I $L(ORBADTDT) S VAINDT=$$FMADD^XLFDT(ORBADTDT,"","","","-1")
 ;
 I ORN=18 S VAINDT=$P($G(ORDGPMA),U)  ;if admission use this visit d/t
 ;
 I $L($G(VAINDT)) D
 .D INP^VADPT  ;get new VAIN array for appropriate visit
 .S ORBPRIM=+$P(VAIN(2),U),ORBATTD=+$P(VAIN(11),U)
 Q
 ;
DEFDIV(ORDUZ) ; Return user's default division, if specified.
 ;
 N ORDD,ORDIV,ORGOOD,ORZ,ORZERR
 ;
 S ORDIV=""
 S Y=0,(ORDD,ORGOOD)=0             ; Initialize variables.
 ;
 ; Get list of divisions from NEW PERSON file multiple:
 D LIST^DIC(200.02,","_ORDUZ_",","@;.01;1","QP","","","","","","","ORZ","ORZERR")
 I $P(ORZ("DILIST",0),U)=0 Q       ; No Divisions listed.
 ;
 F  S ORDD=$O(ORZ("DILIST",ORDD)) Q:+ORDD=0!'($L(ORDD))  D  Q:ORGOOD
 .; See if current entry being processed is "Default" (done if so):
 .I $P(ORZ("DILIST",ORDD,0),U,3)["Y" S ORDIV=$P(ORZ("DILIST",ORDD,0),U,1,2),ORGOOD=1
 Q ORDIV
 ;
ORDIV(ORNUM) ; Return order's division based upon patient's location when order was placed
 ;
 Q:+$G(ORNUM)<1 ""
 Q:'$D(^OR(100,ORNUM,0)) ""
 N ORDIV,PTLOC
 S ORDIV=""
 S PTLOC=+$P(^OR(100,ORNUM,0),U,10)
 Q:$G(PTLOC)<1 ""
 S ORDIV=$P(^SC(PTLOC,0),U,4)  ;DBIA #10040
 Q ORDIV
 
--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORB31   6670     printed  Sep 23, 2025@20:03:33                                                                                                                                                                                                       Page 2
ORB31     ; slc/CLA - Routine to support OE/RR 3 notifications ;06/27/17  07:14
 +1       ;;3.0;ORDER ENTRY/RESULTS REPORTING;**6,31,88,105,139,173,220,215,329,452**;Dec 17, 1997;Build 2
QUEUE(ORN,ORBDFN,ORNUM,ORBADUZ,ORBPMSG,ORBPDATA,ORBH,ORBD,ORDGPMA,ORFORCE) ;
 +1       ;queue up notif for Taskman processing
 +2       ;ORN       notification ien from file 100.9
 +3       ;ORBDFN    patient dfn from file 2
 +4       ;ORNUM     order number from file 100
 +5       ;ORBADUZ   array of potential user recipients (iens from file 100)
 +6       ;ORBPMSG   alert message from triggering process
 +7       ;ORBPDATA  data potentially used in alert follow-up action
 +8       ;ORBH      $H formatted time to begin Taskman process
 +9       ;ORBD      process description for Taskman
 +10      ;ORDGPMA   DGPMA if alert triggered by A/D/T event
 +11      ;ORFORCE   set array of DUZs that should get alert even if not on
 +12      ;
 +13       NEW ZTCPU,ZTDESC,ZTDTH,ZTIO,ZTPAR,ZTPRE,ZTPRI,ZTREQ,ZTRTN,ZTSAVE,ZTSK,ZTUCI,X,Y,DIC
 +14      ;
 +15       SET DIC="3.5"
           SET X="ORB NOTIFICATION RESOURCE"
           SET DIC(0)="X"
           DO ^DIC
 +16       IF (Y)
               SET ZTIO=$PIECE(Y,U,2)
 +17      IF '$TEST
               SET ZTIO=""
 +18       SET ZTDTH=ORBH
           SET ZTRTN="ZTSK^ORB3"
 +19       SET ZTDESC=ORBD
 +20       SET ZTDESC=ZTDESC_"for ("_ORBDFN_") "_$PIECE($GET(^DPT(+ORBDFN,0)),U,1)
 +21       KILL ZTSAVE,ZTCPU,ZTUCI,ZTPRI,ZTPAR,ZTPRE,DIC,Y,DTOUT,DUOUT
 +22      ;
 +23       SET ZTSAVE("ORN")=""
 +24       SET ZTSAVE("ORBDFN")=""
 +25       SET ZTSAVE("ORNUM")=""
 +26       SET ZTSAVE("ORBADUZ(")=""
 +27       SET ZTSAVE("ORBPMSG")=""
 +28       SET ZTSAVE("ORBPDATA")=""
 +29       SET ZTSAVE("ORDGPMA")=""
 +30       SET ZTSAVE("ORFORCE(")=""
 +31       DO ^%ZTLOAD
 +32       QUIT 
DUP(ORN,ORBDFN,ORBPMSG,ORNUM) ;ext funct return "1" if a duplicate notif w/in 1 min.
 +1        NEW ORBDUP,ORBNOW,ORBLAST,ORLNUM,ORSAMEP,ORSAMEREC
 +2        SET ORBDUP=0
 +3        SET ORSAMEP=0
 +4        SET ORBNOW=$$NOW^XLFDT
 +5        SET ^XTMP("ORBDUP",0)=$$FMADD^XLFDT(ORBNOW,1,"","","")_"^"_ORBNOW
 +6        IF '$LENGTH($GET(^XTMP("ORBDUP",ORBDFN_";"_ORN_";"_ORBPMSG)))
               SET ^XTMP("ORBDUP",ORBDFN_";"_ORN_";"_ORBPMSG)=ORBNOW_"^"_$GET(ORNUM)
 +7       IF '$TEST
               Begin DoDot:1
 +8                SET ORBLAST=$GET(^XTMP("ORBDUP",ORBDFN_";"_ORN_";"_ORBPMSG))
 +9                SET ORLNUM=$PIECE(ORBLAST,"^",2)
 +10               SET ORBLAST=$PIECE(ORBLAST,"^")
 +11      ;same provider as last order that triggered this notif
                   IF $LENGTH($GET(ORNUM))
                       IF $LENGTH($GET(ORLNUM))
                           IF ($$ORDERER^ORQOR2(ORNUM)=$$ORDERER^ORQOR2(ORLNUM))
                               SET ORSAMEP=1
 +12               SET ORSAMEREC=1
                   IF ORN=6
                       IF ($$RECIP($GET(ORNUM))'=$$RECIP($GET(ORLNUM)))
                           SET ORSAMEREC=0
 +13      ;if last occurrence of this "NOT" notif was w/in past 1 min, its a dup
 +14      ;dup
                   IF ORBNOW<$$FMADD^XLFDT(ORBLAST,"","",1,"")
                       IF ORSAMEP=1
                           IF ORSAMEREC=1
                               SET ORBDUP=1
 +15      ;refresh last pt/noti occ.
                  IF '$TEST
                       SET ^XTMP("ORBDUP",ORBDFN_";"_ORN_";"_ORBPMSG)=ORBNOW_"^"_ORNUM
               End DoDot:1
 +16      ;clean up old ^XTMP("ORBUP") entries
           DO DUPCLN(ORBNOW)
 +17       QUIT ORBDUP
RECIP(ORNUM)  NEW ORI,RECIP
 +1        if 'ORNUM
               QUIT 0
 +2        SET ORI=0
           FOR 
               SET ORI=$ORDER(^OR(100,ORNUM,8,ORI))
               if 'ORI
                   QUIT 
               Begin DoDot:1
 +3                IF '$PIECE($GET(^OR(100,ORNUM,8,ORI,3)),U,6)&($PIECE($GET(^OR(100,ORNUM,8,ORI,3)),U,9))
                       SET RECIP=$PIECE($GET(^OR(100,ORNUM,8,ORI,3)),U,9)
               End DoDot:1
 +4        QUIT $GET(RECIP)
REGDEV(ORBDA) ;send to regular recipient devices
 +1        NEW ORBDT,ORBD
 +2        SET ORBD=""
 +3        SET ORBDT=$$NOW^XLFDT
 +4        FOR 
               SET ORBD=$ORDER(ORBDA(ORBD))
               if ORBD=""
                   QUIT 
               Begin DoDot:1
 +5                SET ZTRTN="PRINTD^ORB31"
                   SET ZTDESC="Print Notification to Device"
                   SET ZTDTH=$HOROLOG
 +6                SET ZTIO=ORBD
                   SET ZTSAVE("XQAMSG")=""
                   SET ZTSAVE("ORBDT")=""
 +7                DO ^%ZTLOAD
               End DoDot:1
 +8        QUIT 
PRINTD    ;print queued notification to device - setup via REGDEV^ORB3
 +1        IF $GET(ZTSK)
               DO KILL^%ZTLOAD
 +2       ;write msg to a file then quit
           IF IOT="HFS"
               WRITE XQAMSG
               QUIT 
 +3        WRITE !!!,"          ***** NOTIFICATION PROCESSED *****",!!
 +4        WRITE $$FMTE^XLFDT(ORBDT),"   "
 +5        WRITE XQAMSG
 +6        IF $EXTRACT(IOST,1,2)'="C-"
               WRITE @IOF
 +7        QUIT 
FWD(ORY,ORBLST,ORBRECIP,ORBTYPE,ORBCOMNT) ; forward a notification
 +1        IF ORBLST=""
               SET ORY=0
               QUIT 
 +2        SET ORBLST(1)=ORBLST
 +3        DO FORWARD^XQALFWD(.ORBLST,.ORBRECIP,ORBTYPE,ORBCOMNT)
 +4        SET ORY=1
 +5        QUIT 
RENEW(ORY,XQAID) ; renew/restore an alert/notification
 +1        if $LENGTH($GET(XQAID))<1
               QUIT 
 +2        KILL XQAKILL
 +3       ;DBIA #4100
           IF '$DATA(^XTV(8992,"AXQA",XQAID,DUZ))
               DO RESTORE^XQALERT1
 +4        SET ORY=1
 +5        QUIT 
TERMLKUP(OCXARR,OCXTERM) ; extrinsic function returns the local terms
 +1       ; linked to the nat'l OCX term in an array and the file where those
 +2       ; array terms can be found. The value of the extrinsic function is the
 +3       ; file pointed to for the local terms.
 +4       ;
 +5       ; OCXARR  - Array of local terms
 +6       ; OCXTERM - OCX nat'l term from file ^OCXS(860.9
 +7       ;
 +8        NEW OCXI,OCXJ,FILE,I
 +9        SET OCXI=""
           SET OCXJ=0
           SET FILE=""
           SET I=1
 +10       SET OCXI=$ORDER(^OCXS(860.9,"B",OCXTERM,OCXI))
 +11       IF +$GET(OCXI)>0
               Begin DoDot:1
 +12               SET FILE=$PIECE(^OCXS(860.9,OCXI,0),U,2)
 +13               FOR 
                       SET OCXJ=$ORDER(^OCXS(860.9,OCXI,1,OCXJ))
                       if +OCXJ<1
                           QUIT 
                       Begin DoDot:2
 +14                       SET OCXARR(I)=$PIECE(^OCXS(860.9,OCXI,1,OCXJ,0),U,2)_U_$PIECE(^(0),U)
 +15                       SET OCXARR=I
                           SET I=I+1
                       End DoDot:2
               End DoDot:1
 +16       QUIT FILE
DUPCLN(ORBNOW) ;clean up old entires in ^XTMP("ORBDUP")
 +1        NEW ORBX,ORBDT,ORNDT
 +2       ;entries older than 5 minutes
           SET ORNDT=$$FMADD^XLFDT(ORBNOW,"","",-5,"")
 +3        SET ORBX=0
 +4        FOR 
               SET ORBX=$ORDER(^XTMP("ORBDUP",ORBX))
               if ORBX=""
                   QUIT 
               Begin DoDot:1
 +5                SET ORBDT=+$GET(^XTMP("ORBDUP",ORBX))
 +6                IF $LENGTH(ORBDT)
                       IF (ORBDT<ORNDT)
                           KILL ^XTMP("ORBDUP",ORBX)
               End DoDot:1
 +7        QUIT 
TMDEV(ORBTM) ;returns Device for a team in format device ien^device name
 +1        NEW ORBTDEV,ORBTDEVN
 +2        SET ORBTDEVN=""
 +3        if '$LENGTH($GET(ORBTM))
               QUIT ""
 +4        if '$DATA(^OR(100.21,ORBTM,0))
               QUIT ""
 +5       ;get Team's device
           SET ORBTDEV=$PIECE(^OR(100.21,ORBTM,0),U,4)
 +6        if +$GET(ORBTDEV)<1
               QUIT ""
 +7       ;DBIA #10114
           SET X="`"_ORBTDEV
           SET DIC=3.5
           SET DIC(0)=""
           DO ^DIC
 +8        if +Y<1
               QUIT ""
 +9        SET ORBTDEVN=$PIECE(Y,U,2)
 +10       KILL DIC,Y,X
 +11       QUIT ORBTDEV_U_ORBTDEVN
ENTITY(ORNUM) ;ext funct. rtns entity for parameter use
 +1        NEW ORBENT
 +2        SET ORBENT="DIV^SYS^PKG"
 +3       ;if order number use pt's location division
           IF $LENGTH($GET(ORNUM))
               Begin DoDot:1
 +4                NEW ORDIV
 +5                SET ORDIV=0
                   SET ORDIV=$$ORDIV(ORNUM)
 +6                IF +$GET(ORDIV)>0
                       SET ORBENT=ORDIV_";DIC(4,^SYS^PKG"
               End DoDot:1
 +7        QUIT ORBENT
 +8       ;
ADT(ORN,ORBDFN,ORBPRIM,ORBATTD,ORDGPMA) ;get inpt primary and attending for ADT notifs
 +1        NEW ORBADTDT,VAINDT
 +2       ;if notif is deceased or discharge use prev visit d/t:
 +3        IF (ORN=20)!(ORN=35)
               Begin DoDot:1
 +4                SET ORBADTDT=$SELECT($DATA(ORDGPMA):$PIECE(ORDGPMA,U),1:$PIECE($GET(^DPT(ORBDFN,.35)),U))
 +5                IF $LENGTH(ORBADTDT)
                       SET VAINDT=$$FMADD^XLFDT(ORBADTDT,"","","","-1")
               End DoDot:1
 +6       ;
 +7       ;if admission use this visit d/t
           IF ORN=18
               SET VAINDT=$PIECE($GET(ORDGPMA),U)
 +8       ;
 +9        IF $LENGTH($GET(VAINDT))
               Begin DoDot:1
 +10      ;get new VAIN array for appropriate visit
                   DO INP^VADPT
 +11               SET ORBPRIM=+$PIECE(VAIN(2),U)
                   SET ORBATTD=+$PIECE(VAIN(11),U)
               End DoDot:1
 +12       QUIT 
 +13      ;
DEFDIV(ORDUZ) ; Return user's default division, if specified.
 +1       ;
 +2        NEW ORDD,ORDIV,ORGOOD,ORZ,ORZERR
 +3       ;
 +4        SET ORDIV=""
 +5       ; Initialize variables.
           SET Y=0
           SET (ORDD,ORGOOD)=0
 +6       ;
 +7       ; Get list of divisions from NEW PERSON file multiple:
 +8        DO LIST^DIC(200.02,","_ORDUZ_",","@;.01;1","QP","","","","","","","ORZ","ORZERR")
 +9       ; No Divisions listed.
           IF $PIECE(ORZ("DILIST",0),U)=0
               QUIT 
 +10      ;
 +11       FOR 
               SET ORDD=$ORDER(ORZ("DILIST",ORDD))
               if +ORDD=0!'($LENGTH(ORDD))
                   QUIT 
               Begin DoDot:1
 +12      ; See if current entry being processed is "Default" (done if so):
 +13               IF $PIECE(ORZ("DILIST",ORDD,0),U,3)["Y"
                       SET ORDIV=$PIECE(ORZ("DILIST",ORDD,0),U,1,2)
                       SET ORGOOD=1
               End DoDot:1
               if ORGOOD
                   QUIT 
 +14       QUIT ORDIV
 +15      ;
ORDIV(ORNUM) ; Return order's division based upon patient's location when order was placed
 +1       ;
 +2        if +$GET(ORNUM)<1
               QUIT ""
 +3        if '$DATA(^OR(100,ORNUM,0))
               QUIT ""
 +4        NEW ORDIV,PTLOC
 +5        SET ORDIV=""
 +6        SET PTLOC=+$PIECE(^OR(100,ORNUM,0),U,10)
 +7        if $GET(PTLOC)<1
               QUIT ""
 +8       ;DBIA #10040
           SET ORDIV=$PIECE(^SC(PTLOC,0),U,4)
 +9        QUIT ORDIV