- ORB3USER ; slc/CLA - Alert recipient algorithms for OE/RR 3 notifications; 1/19/00 14:45 [8/16/05 9:53am]
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**74,91,105,139,200,220**;Dec 17, 1997
- USER(XQA,ORBDUZ,ORN,ORBU,ORBUI,ORBDFN,ORNUM) ;called from ORB3
- ;check to see if potential recip (ORBDUZ) should be an alert recip
- ;XQA array of alert recips passed to Kernel Alert Utility
- ;ORBDUZ duz of current potential alert recipient
- ;ORN notif ien from file 100.9
- ;ORBU array of info for utility displaying recip who and why
- ;ORBUI counter for utility array
- ;ORBDFN patient ien from Patient file [#2]
- ;ORNUM order number to base division params on[optional]
- ;
- N ORBNODE,ORBSUR,ORBTM,ORBTMF,ORBTEAM,ORBON,ORBDUP
- I $G(ORBDUZ)["G." S XQA(ORBDUZ)="" Q
- Q:+$G(ORBDUZ)<.5
- ;
- S ORBTM=$P(ORBDUZ,U,2) I $L(ORBTM) D ;if user recip via team
- .S ORBTMF=$$GET^XPAR(ORBTM_";OR(100.21,","ORB PROCESSING FLAG",ORN,"I")
- .S ORBTEAM=ORBTMF_U_$P(^OR(100.21,ORBTM,0),U)
- .I $D(ORBU) D
- ..S ORBU(ORBUI)=" User "_$P(^VA(200,+ORBDUZ,0),U)_" is a potential recipient via team "_$P(ORBTEAM,U,2),ORBUI=ORBUI+1
- ;
- I '$D(ORBU) D
- .I $L($G(ORBTMF))=0 D
- ..S:$D(^XTMP("ORBUSER",$J,+ORBDUZ)) ORBDUP=1
- ..S ^XTMP("ORBUSER",$J,+ORBDUZ)=""
- Q:$G(ORBDUP)=1 ;quit if user already processed and no team param value
- ;
- S ORBDUZ=$P(ORBDUZ,U)
- ;
- S:$G(ORBTEAM)="" ORBTEAM="^"
- S ORBON=$$ONOFF(ORN,ORBDUZ,ORBDFN,ORBTEAM,$G(ORNUM))
- I $D(ORBU) D
- .S ORBNODE=$G(^VA(200,ORBDUZ,0)) I $L($G(ORBNODE)) D
- ..S ORBU(ORBUI)=" "_$P(ORBNODE,U)_": "_$P(ORBON,U)_" because ",ORBUI=ORBUI+1
- ..S ORBU(ORBUI)=" "_$P(ORBON,U,2),ORBUI=ORBUI+1
- I $D(ORBU),($P(ORBON,U)="ON"),($G(ORBDUZ)'["G.") D
- .S ORBSUR=$$ACTVSURO^XQALSURO(ORBDUZ) ;DBIA 2790 Alert surrogate
- .I +$G(ORBSUR)>0 D
- ..S ORBU(ORBUI)=" [Surrogate "_$$GET1^DIQ(200,ORBSUR_",",.01)_" will receive alert for user]",ORBUI=ORBUI+1
- Q:$P(ORBON,U)="OFF" ;quit if user is disabled for this notif
- Q:$D(ORBU) ;quit if entered rtn via UTL (do not sent alert)
- D PREALERT(ORBDUZ,ORN,ORBDFN) ;if user has undel prev alert, delete it
- S XQA(ORBDUZ)="" ;send alert to the user
- Q
- ;
- PREALERT(ORBDUZ,ORN,ORBDFN) ;if user (ORBDUZ) has an undeleted previous
- ;version of this alert (ORN) for patient (ORBDFN), delete it
- ;
- Q:$P(^ORD(100.9,ORN,0),U,4)'="NOT" ;quit if not a "NOT" notif/alert
- N XQAID,XQAKILL,XQAUSER,ORBDT
- S XQAID="OR,"_ORBDFN_","_ORN
- I $D(^XTV(8992,"AXQAN",XQAID,ORBDUZ)) D ;DBIA# 2689
- .S ORBDT=0,ORBDT=$O(^XTV(8992,"AXQAN",XQAID,ORBDUZ,ORBDT))
- .I $G(ORBDT)>0 D
- ..S XQAUSER=ORBDUZ
- ..S XQAKILL=1
- ..D DELETEA^XQALERT
- Q
- ;
- ONOFF(ORN,ORBUSR,ORBPT,ORBTEAM,ORNUM) ;Extrinsic function to check param file
- ;determines if user ORBUSR should receive notification ORN for patient
- ;patient ORBPT. If ORBUSR was derived via teams, ORBTEAM may be used.
- ;ORN notification ien from file 100.9 (req'd)
- ;ORBUSR user ien from file 200 (req'd)
- ;ORBPT patient ien from file 2 (not req'd)
- ;ORBTEAM processing flag^name for team assoc. w/ORBUSR (not req'd)
- ;ORNUM order number to base division params on (not req'd)
- N NODE,ORBPTN,ORBNOTN,ORBUSRF,ORBUSRN,ORBLOC,ORBLOCF,ORBLOCN
- S (ORBPTN,ORBNOTN,ORBUSRF,ORBUSRN,ORBLOC,ORBLOCF,ORBLOCN)=""
- N ORBSRV,ORBSRVF,ORBSRVN,ORBTEA,ORBTEAF,ORBTEAN,ORBTEAD,ORBTEAE
- S (ORBSRV,ORBSRVF,ORBSRVN,ORBTEA,ORBTEAF,ORBTEAN,ORBTEAD,ORBTEAE)=""
- N ORBCLS,ORBCLSF,ORBCLSN,ORBLST,ORBI
- S (ORBCLS,ORBCLSF,ORBCLSN)=""
- N ORBDIV,ORBDIVF,ORBDIVN,ORBSYSF,ORBPKGF
- S (ORBDIV,ORBDIVF,ORBDIVN,ORBSYSF,ORBPKGF)=""
- ;
- ;get notification name:
- S NODE=$G(^ORD(100.9,ORN,0)) S:$L($G(NODE)) ORBNOTN=$P(NODE,U)
- ;
- ;get user name:
- S NODE=$G(^VA(200,ORBUSR,0)) S:$L($G(NODE)) ORBUSRN=$P(NODE,U)
- ;
- ;get patient name:
- S:$L($G(ORBPT)) NODE=$G(^DPT(ORBPT,0)) S:$L($G(NODE)) ORBPTN=$P(NODE,U)
- ;
- ;get division flag and name:
- S ORBDIV=$$DIVF(ORBUSR,ORN,$G(ORNUM))
- I $L(ORBDIV) D
- .S ORBDIVF=$P(ORBDIV,U,2),ORBDIV=$P(ORBDIV,U),NODE=$G(^DIC(4,ORBDIV,0))
- .S:$L($G(NODE)) ORBDIVN=$P(NODE,U)
- ;
- ;get system flag:
- S ORBSYSF=$$GET^XPAR("SYS","ORB PROCESSING FLAG",ORN,"I")
- ;
- ;get OE/RR package-export flag:
- S ORBPKGF=$$GET^XPAR("PKG","ORB PROCESSING FLAG",ORN,"I")
- ;
- ;get patient's location flag (INPATIENT ONLY - outpt locations cannot be
- ;reliably determined, and many simultaneous outpt locations can occur):
- I +$G(ORBPT)>0 D
- .N DFN S DFN=ORBPT,VA200="" D OERR^VADPT
- .S ORBLOC=+$G(^DIC(42,+VAIN(4),44)) I +$G(ORBLOC)>0 D
- ..S ORBLOCN=$P(^SC(+ORBLOC,0),U)
- ..S ORBLOCF=$$GET^XPAR(+$G(ORBLOC)_";SC(","ORB PROCESSING FLAG",ORN,"I")
- K VA200,VAIN
- ;
- ;get user's service/section flag:
- S ORBSRV=$G(^VA(200,ORBUSR,5)) I +ORBSRV>0 S ORBSRV=$P(ORBSRV,U) D
- .S NODE=$G(^DIC(49,ORBSRV,0)) S:$L($G(NODE)) ORBSRVN=$P(NODE,U)
- .S:+$G(ORBSRV)>0 ORBSRVF=$$GET^XPAR(ORBSRV_";DIC(49,","ORB PROCESSING FLAG",ORN,"I")
- ;
- ;get user's team flag:
- I $L($G(ORBTEAM)) S ORBTEAF=$P(ORBTEAM,U),ORBTEAN=$P(ORBTEAM,U,2)
- ;
- ;get class flag for the user's most recently active ASU class
- ;S ORBCLS=$$RECENT(ORBUSR) I $L($G(ORBCLS))>0 D
- ;.S ORBCLSN=$P(ORBCLS,U,2),ORBCLS=$P(ORBCLS,U)
- ;.S:+$G(ORBCLS)>0 ORBCLSF=$$GET^XPAR(ORBCLS_";USR(8930,","ORB PROCESSING FLAG",ORN,"I")
- ;
- ;get user's flag:
- S ORBUSRF=$$GET^XPAR(ORBUSR_";VA(200,","ORB PROCESSING FLAG",ORN,"I")
- ;
- ;determine overall flag:
- I $G(ORBUSRF)="M" Q "ON^User "_ORBUSRN_" is Mandatory.^User value is Mandatory"
- I $G(ORBUSRF)="E" Q "ON^User "_ORBUSRN_" is Enabled.^User value is Enabled"
- ;I $G(ORBCLSF)="M" Q "ON^User's class "_ORBCLSN_" is Mandatory.^User's class "_ORBCLSN_" value is Mandatory"
- I $G(ORBTEAF)="M" Q "ON^User's team "_ORBTEAN_" is Mandatory.^User's team "_ORBTEAN_" value is Mandatory"
- I $G(ORBTEAF)="D" Q "OFF^User's team "_ORBTEAN_" is Disabled.^User's team "_ORBTEAN_" value is Disabled"
- I $G(ORBSRVF)="M" Q "ON^User's service "_ORBSRVN_" is Mandatory.^User's service "_ORBSRVN_" value is Mandatory"
- I $G(ORBLOCF)="M" Q "ON^Patient's location "_ORBLOCN_" is Mandatory.^Pt's location "_ORBLOCN_" value is Mandatory"
- I $G(ORBLOCF)="D" Q "OFF^Patient's location "_ORBLOCN_" is Disabled.^Pt's location "_ORBLOCN_" value is Disabled"
- I $G(ORBDIVF)="M",($G(ORBLOCF)="") Q "ON^Division "_ORBDIVN_" is Mandatory, no Pt Location value.^Division "_ORBDIVN_" value is Mandatory"
- I $G(ORBSYSF)="M",($G(ORBDIVF)=""),($G(ORBLOCF)="") Q "ON^System default is Mandatory, no Division or Pt Location values.^System value is Mandatory"
- I $G(ORBPKGF)="M",($G(ORBSYSF)=""),($G(ORBDIVF)=""),($G(ORBLOCF)="") Q "ON^OERR default is Mandatory, no Division, System, or Pt Location values.^OERR value is Mandatory"
- I $G(ORBUSRF)="D" Q "OFF^User "_ORBUSRN_" is Disabled - no Mandatory values found.^User value is Disabled"
- ;I $G(ORBCLSF)="D" Q "OFF^User's class "_ORBCLSN_" is Disabled - no Mandatory values found.^User's class "_ORBCLSN_" value is Disabled""
- I $G(ORBTEAF)="E" Q "ON^User's team "_ORBTEAN_" is Enabled.^User's team "_ORBTEAN_" value is Enabled"
- I $G(ORBSRVF)="D" Q "OFF^User's service "_ORBSRVN_" is Disabled.^User's service "_ORBSRVN_" value is Disabled"
- I $G(ORBSRVF)="E" Q "ON^User's service "_ORBSRVN_" is Enabled.^User's service "_ORBSRVN_" value is Enabled"
- I $G(ORBLOCF)="E" Q "ON^Patient's location "_ORBLOCN_" is Enabled.^Pt's location "_ORBLOCN_" value is Enabled"
- I $G(ORBDIVF)="D" Q "OFF^Division "_ORBDIVN_" is Disabled.^Division "_ORBDIVN_" value is Disabled"
- I $G(ORBDIVF)="E" Q "ON^Division "_ORBDIVN_" is Enabled.^Division "_ORBDIVN_" value is Enabled"
- I $G(ORBSYSF)="D" Q "OFF^System default is Disabled.^System value is Disabled"
- I $G(ORBSYSF)="E" Q "ON^System default is Enabled.^System value is Enabled"
- I $G(ORBPKGF)="D" Q "OFF^OERR default is Disabled.^OERR value is Disabled"
- I $G(ORBPKGF)="E" Q "ON^OERR default is Enabled.^OERR value is Enabled"
- Q "OFF^No Mandatory, Disabled or Enabled values found.^No Mandatory/Disabled/Enabled values"
- ;
- RECENT(USER) ;ext funct rtns a user's most recent, active user class
- Q:+$G(USER)<1 "^Error: User not identified."
- N CLS,CLASS,INACT,ACT,ORX,INVDT,RESULT
- ;call api to determine user's class(es)
- Q:'$L($G(CLS(0))) "^No user classes found."
- D NOW^%DTC
- S CLASS="" F S CLASS=$O(CLS(CLASS)) Q:CLASS="" D
- .S INACT=$P(CLS(CLASS),U,5),ACT=$P(CLS(CLASS),U,4)
- .I INACT,(INACT<%) Q ;quit if class has an inactive date before now
- .Q:'ACT ;quit if class has no active date
- .S ORX("DT",9999999-ACT)=$P(CLS(CLASS),U)_U_CLASS
- S INVDT="",INVDT=$O(ORX("DT",INVDT))
- I INVDT S RESULT=ORX("DT",INVDT)
- E S RESULT="^No user classes found."
- K %
- Q RESULT
- DIVF(USER,ORN,ORNUM) ;ext funct rtns user's division value for ORB PROCESSING FLAG
- N DIV,DIVF,MDIVF,EDIVF,DDIVF
- I +$G(ORNUM) D Q DIVF
- .S DIVF=""
- .S DIV=$$ORDIV^ORB31(ORNUM)
- .I +$G(DIV)'>0 Q
- .S DIVF=$$GET^XPAR(DIV_";DIC(4,","ORB PROCESSING FLAG",ORN,"I")
- .I $L(DIVF) S DIVF=DIV_U_DIVF
- S DIV=0,(DIVF,MDIVF,EDIVF,DDIVF)=""
- F S DIV=$O(^VA(200,USER,2,"B",DIV)) Q:+$G(DIV)<1!(DIVF="M") D
- .S DIVF=$$GET^XPAR(DIV_";DIC(4,","ORB PROCESSING FLAG",ORN,"I")
- .I DIVF="M" S MDIVF=DIV_U_DIVF
- .I DIVF="E" S EDIVF=DIV_U_DIVF
- .I DIVF="D" S DDIVF=DIV_U_DIVF
- Q:$L(MDIVF) MDIVF
- Q:$L(EDIVF) EDIVF
- Q:$L(DDIVF) DDIVF
- Q ""
- ORB3USER ; slc/CLA - Alert recipient algorithms for OE/RR 3 notifications; 1/19/00 14:45 [8/16/05 9:53am]
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**74,91,105,139,200,220**;Dec 17, 1997
- USER(XQA,ORBDUZ,ORN,ORBU,ORBUI,ORBDFN,ORNUM) ;called from ORB3
- +1 ;check to see if potential recip (ORBDUZ) should be an alert recip
- +2 ;XQA array of alert recips passed to Kernel Alert Utility
- +3 ;ORBDUZ duz of current potential alert recipient
- +4 ;ORN notif ien from file 100.9
- +5 ;ORBU array of info for utility displaying recip who and why
- +6 ;ORBUI counter for utility array
- +7 ;ORBDFN patient ien from Patient file [#2]
- +8 ;ORNUM order number to base division params on[optional]
- +9 ;
- +10 NEW ORBNODE,ORBSUR,ORBTM,ORBTMF,ORBTEAM,ORBON,ORBDUP
- +11 IF $GET(ORBDUZ)["G."
- SET XQA(ORBDUZ)=""
- QUIT
- +12 IF +$GET(ORBDUZ)<.5
- QUIT
- +13 ;
- +14 ;if user recip via team
- SET ORBTM=$PIECE(ORBDUZ,U,2)
- IF $LENGTH(ORBTM)
- Begin DoDot:1
- +15 SET ORBTMF=$$GET^XPAR(ORBTM_";OR(100.21,","ORB PROCESSING FLAG",ORN,"I")
- +16 SET ORBTEAM=ORBTMF_U_$PIECE(^OR(100.21,ORBTM,0),U)
- +17 IF $DATA(ORBU)
- Begin DoDot:2
- +18 SET ORBU(ORBUI)=" User "_$PIECE(^VA(200,+ORBDUZ,0),U)_" is a potential recipient via team "_$PIECE(ORBTEAM,U,2)
- SET ORBUI=ORBUI+1
- End DoDot:2
- End DoDot:1
- +19 ;
- +20 IF '$DATA(ORBU)
- Begin DoDot:1
- +21 IF $LENGTH($GET(ORBTMF))=0
- Begin DoDot:2
- +22 IF $DATA(^XTMP("ORBUSER",$JOB,+ORBDUZ))
- SET ORBDUP=1
- +23 SET ^XTMP("ORBUSER",$JOB,+ORBDUZ)=""
- End DoDot:2
- End DoDot:1
- +24 ;quit if user already processed and no team param value
- IF $GET(ORBDUP)=1
- QUIT
- +25 ;
- +26 SET ORBDUZ=$PIECE(ORBDUZ,U)
- +27 ;
- +28 IF $GET(ORBTEAM)=""
- SET ORBTEAM="^"
- +29 SET ORBON=$$ONOFF(ORN,ORBDUZ,ORBDFN,ORBTEAM,$GET(ORNUM))
- +30 IF $DATA(ORBU)
- Begin DoDot:1
- +31 SET ORBNODE=$GET(^VA(200,ORBDUZ,0))
- IF $LENGTH($GET(ORBNODE))
- Begin DoDot:2
- +32 SET ORBU(ORBUI)=" "_$PIECE(ORBNODE,U)_": "_$PIECE(ORBON,U)_" because "
- SET ORBUI=ORBUI+1
- +33 SET ORBU(ORBUI)=" "_$PIECE(ORBON,U,2)
- SET ORBUI=ORBUI+1
- End DoDot:2
- End DoDot:1
- +34 IF $DATA(ORBU)
- IF ($PIECE(ORBON,U)="ON")
- IF ($GET(ORBDUZ)'["G.")
- Begin DoDot:1
- +35 ;DBIA 2790 Alert surrogate
- SET ORBSUR=$$ACTVSURO^XQALSURO(ORBDUZ)
- +36 IF +$GET(ORBSUR)>0
- Begin DoDot:2
- +37 SET ORBU(ORBUI)=" [Surrogate "_$$GET1^DIQ(200,ORBSUR_",",.01)_" will receive alert for user]"
- SET ORBUI=ORBUI+1
- End DoDot:2
- End DoDot:1
- +38 ;quit if user is disabled for this notif
- IF $PIECE(ORBON,U)="OFF"
- QUIT
- +39 ;quit if entered rtn via UTL (do not sent alert)
- IF $DATA(ORBU)
- QUIT
- +40 ;if user has undel prev alert, delete it
- DO PREALERT(ORBDUZ,ORN,ORBDFN)
- +41 ;send alert to the user
- SET XQA(ORBDUZ)=""
- +42 QUIT
- +43 ;
- PREALERT(ORBDUZ,ORN,ORBDFN) ;if user (ORBDUZ) has an undeleted previous
- +1 ;version of this alert (ORN) for patient (ORBDFN), delete it
- +2 ;
- +3 ;quit if not a "NOT" notif/alert
- IF $PIECE(^ORD(100.9,ORN,0),U,4)'="NOT"
- QUIT
- +4 NEW XQAID,XQAKILL,XQAUSER,ORBDT
- +5 SET XQAID="OR,"_ORBDFN_","_ORN
- +6 ;DBIA# 2689
- IF $DATA(^XTV(8992,"AXQAN",XQAID,ORBDUZ))
- Begin DoDot:1
- +7 SET ORBDT=0
- SET ORBDT=$ORDER(^XTV(8992,"AXQAN",XQAID,ORBDUZ,ORBDT))
- +8 IF $GET(ORBDT)>0
- Begin DoDot:2
- +9 SET XQAUSER=ORBDUZ
- +10 SET XQAKILL=1
- +11 DO DELETEA^XQALERT
- End DoDot:2
- End DoDot:1
- +12 QUIT
- +13 ;
- ONOFF(ORN,ORBUSR,ORBPT,ORBTEAM,ORNUM) ;Extrinsic function to check param file
- +1 ;determines if user ORBUSR should receive notification ORN for patient
- +2 ;patient ORBPT. If ORBUSR was derived via teams, ORBTEAM may be used.
- +3 ;ORN notification ien from file 100.9 (req'd)
- +4 ;ORBUSR user ien from file 200 (req'd)
- +5 ;ORBPT patient ien from file 2 (not req'd)
- +6 ;ORBTEAM processing flag^name for team assoc. w/ORBUSR (not req'd)
- +7 ;ORNUM order number to base division params on (not req'd)
- +8 NEW NODE,ORBPTN,ORBNOTN,ORBUSRF,ORBUSRN,ORBLOC,ORBLOCF,ORBLOCN
- +9 SET (ORBPTN,ORBNOTN,ORBUSRF,ORBUSRN,ORBLOC,ORBLOCF,ORBLOCN)=""
- +10 NEW ORBSRV,ORBSRVF,ORBSRVN,ORBTEA,ORBTEAF,ORBTEAN,ORBTEAD,ORBTEAE
- +11 SET (ORBSRV,ORBSRVF,ORBSRVN,ORBTEA,ORBTEAF,ORBTEAN,ORBTEAD,ORBTEAE)=""
- +12 NEW ORBCLS,ORBCLSF,ORBCLSN,ORBLST,ORBI
- +13 SET (ORBCLS,ORBCLSF,ORBCLSN)=""
- +14 NEW ORBDIV,ORBDIVF,ORBDIVN,ORBSYSF,ORBPKGF
- +15 SET (ORBDIV,ORBDIVF,ORBDIVN,ORBSYSF,ORBPKGF)=""
- +16 ;
- +17 ;get notification name:
- +18 SET NODE=$GET(^ORD(100.9,ORN,0))
- IF $LENGTH($GET(NODE))
- SET ORBNOTN=$PIECE(NODE,U)
- +19 ;
- +20 ;get user name:
- +21 SET NODE=$GET(^VA(200,ORBUSR,0))
- IF $LENGTH($GET(NODE))
- SET ORBUSRN=$PIECE(NODE,U)
- +22 ;
- +23 ;get patient name:
- +24 IF $LENGTH($GET(ORBPT))
- SET NODE=$GET(^DPT(ORBPT,0))
- IF $LENGTH($GET(NODE))
- SET ORBPTN=$PIECE(NODE,U)
- +25 ;
- +26 ;get division flag and name:
- +27 SET ORBDIV=$$DIVF(ORBUSR,ORN,$GET(ORNUM))
- +28 IF $LENGTH(ORBDIV)
- Begin DoDot:1
- +29 SET ORBDIVF=$PIECE(ORBDIV,U,2)
- SET ORBDIV=$PIECE(ORBDIV,U)
- SET NODE=$GET(^DIC(4,ORBDIV,0))
- +30 IF $LENGTH($GET(NODE))
- SET ORBDIVN=$PIECE(NODE,U)
- End DoDot:1
- +31 ;
- +32 ;get system flag:
- +33 SET ORBSYSF=$$GET^XPAR("SYS","ORB PROCESSING FLAG",ORN,"I")
- +34 ;
- +35 ;get OE/RR package-export flag:
- +36 SET ORBPKGF=$$GET^XPAR("PKG","ORB PROCESSING FLAG",ORN,"I")
- +37 ;
- +38 ;get patient's location flag (INPATIENT ONLY - outpt locations cannot be
- +39 ;reliably determined, and many simultaneous outpt locations can occur):
- +40 IF +$GET(ORBPT)>0
- Begin DoDot:1
- +41 NEW DFN
- SET DFN=ORBPT
- SET VA200=""
- DO OERR^VADPT
- +42 SET ORBLOC=+$GET(^DIC(42,+VAIN(4),44))
- IF +$GET(ORBLOC)>0
- Begin DoDot:2
- +43 SET ORBLOCN=$PIECE(^SC(+ORBLOC,0),U)
- +44 SET ORBLOCF=$$GET^XPAR(+$GET(ORBLOC)_";SC(","ORB PROCESSING FLAG",ORN,"I")
- End DoDot:2
- End DoDot:1
- +45 KILL VA200,VAIN
- +46 ;
- +47 ;get user's service/section flag:
- +48 SET ORBSRV=$GET(^VA(200,ORBUSR,5))
- IF +ORBSRV>0
- SET ORBSRV=$PIECE(ORBSRV,U)
- Begin DoDot:1
- +49 SET NODE=$GET(^DIC(49,ORBSRV,0))
- IF $LENGTH($GET(NODE))
- SET ORBSRVN=$PIECE(NODE,U)
- +50 IF +$GET(ORBSRV)>0
- SET ORBSRVF=$$GET^XPAR(ORBSRV_";DIC(49,","ORB PROCESSING FLAG",ORN,"I")
- End DoDot:1
- +51 ;
- +52 ;get user's team flag:
- +53 IF $LENGTH($GET(ORBTEAM))
- SET ORBTEAF=$PIECE(ORBTEAM,U)
- SET ORBTEAN=$PIECE(ORBTEAM,U,2)
- +54 ;
- +55 ;get class flag for the user's most recently active ASU class
- +56 ;S ORBCLS=$$RECENT(ORBUSR) I $L($G(ORBCLS))>0 D
- +57 ;.S ORBCLSN=$P(ORBCLS,U,2),ORBCLS=$P(ORBCLS,U)
- +58 ;.S:+$G(ORBCLS)>0 ORBCLSF=$$GET^XPAR(ORBCLS_";USR(8930,","ORB PROCESSING FLAG",ORN,"I")
- +59 ;
- +60 ;get user's flag:
- +61 SET ORBUSRF=$$GET^XPAR(ORBUSR_";VA(200,","ORB PROCESSING FLAG",ORN,"I")
- +62 ;
- +63 ;determine overall flag:
- +64 IF $GET(ORBUSRF)="M"
- QUIT "ON^User "_ORBUSRN_" is Mandatory.^User value is Mandatory"
- +65 IF $GET(ORBUSRF)="E"
- QUIT "ON^User "_ORBUSRN_" is Enabled.^User value is Enabled"
- +66 ;I $G(ORBCLSF)="M" Q "ON^User's class "_ORBCLSN_" is Mandatory.^User's class "_ORBCLSN_" value is Mandatory"
- +67 IF $GET(ORBTEAF)="M"
- QUIT "ON^User's team "_ORBTEAN_" is Mandatory.^User's team "_ORBTEAN_" value is Mandatory"
- +68 IF $GET(ORBTEAF)="D"
- QUIT "OFF^User's team "_ORBTEAN_" is Disabled.^User's team "_ORBTEAN_" value is Disabled"
- +69 IF $GET(ORBSRVF)="M"
- QUIT "ON^User's service "_ORBSRVN_" is Mandatory.^User's service "_ORBSRVN_" value is Mandatory"
- +70 IF $GET(ORBLOCF)="M"
- QUIT "ON^Patient's location "_ORBLOCN_" is Mandatory.^Pt's location "_ORBLOCN_" value is Mandatory"
- +71 IF $GET(ORBLOCF)="D"
- QUIT "OFF^Patient's location "_ORBLOCN_" is Disabled.^Pt's location "_ORBLOCN_" value is Disabled"
- +72 IF $GET(ORBDIVF)="M"
- IF ($GET(ORBLOCF)="")
- QUIT "ON^Division "_ORBDIVN_" is Mandatory, no Pt Location value.^Division "_ORBDIVN_" value is Mandatory"
- +73 IF $GET(ORBSYSF)="M"
- IF ($GET(ORBDIVF)="")
- IF ($GET(ORBLOCF)="")
- QUIT "ON^System default is Mandatory, no Division or Pt Location values.^System value is Mandatory"
- +74 IF $GET(ORBPKGF)="M"
- IF ($GET(ORBSYSF)="")
- IF ($GET(ORBDIVF)="")
- IF ($GET(ORBLOCF)="")
- QUIT "ON^OERR default is Mandatory, no Division, System, or Pt Location values.^OERR value is Mandatory"
- +75 IF $GET(ORBUSRF)="D"
- QUIT "OFF^User "_ORBUSRN_" is Disabled - no Mandatory values found.^User value is Disabled"
- +76 ;I $G(ORBCLSF)="D" Q "OFF^User's class "_ORBCLSN_" is Disabled - no Mandatory values found.^User's class "_ORBCLSN_" value is Disabled""
- +77 IF $GET(ORBTEAF)="E"
- QUIT "ON^User's team "_ORBTEAN_" is Enabled.^User's team "_ORBTEAN_" value is Enabled"
- +78 IF $GET(ORBSRVF)="D"
- QUIT "OFF^User's service "_ORBSRVN_" is Disabled.^User's service "_ORBSRVN_" value is Disabled"
- +79 IF $GET(ORBSRVF)="E"
- QUIT "ON^User's service "_ORBSRVN_" is Enabled.^User's service "_ORBSRVN_" value is Enabled"
- +80 IF $GET(ORBLOCF)="E"
- QUIT "ON^Patient's location "_ORBLOCN_" is Enabled.^Pt's location "_ORBLOCN_" value is Enabled"
- +81 IF $GET(ORBDIVF)="D"
- QUIT "OFF^Division "_ORBDIVN_" is Disabled.^Division "_ORBDIVN_" value is Disabled"
- +82 IF $GET(ORBDIVF)="E"
- QUIT "ON^Division "_ORBDIVN_" is Enabled.^Division "_ORBDIVN_" value is Enabled"
- +83 IF $GET(ORBSYSF)="D"
- QUIT "OFF^System default is Disabled.^System value is Disabled"
- +84 IF $GET(ORBSYSF)="E"
- QUIT "ON^System default is Enabled.^System value is Enabled"
- +85 IF $GET(ORBPKGF)="D"
- QUIT "OFF^OERR default is Disabled.^OERR value is Disabled"
- +86 IF $GET(ORBPKGF)="E"
- QUIT "ON^OERR default is Enabled.^OERR value is Enabled"
- +87 QUIT "OFF^No Mandatory, Disabled or Enabled values found.^No Mandatory/Disabled/Enabled values"
- +88 ;
- RECENT(USER) ;ext funct rtns a user's most recent, active user class
- +1 IF +$GET(USER)<1
- QUIT "^Error: User not identified."
- +2 NEW CLS,CLASS,INACT,ACT,ORX,INVDT,RESULT
- +3 ;call api to determine user's class(es)
- +4 IF '$LENGTH($GET(CLS(0)))
- QUIT "^No user classes found."
- +5 DO NOW^%DTC
- +6 SET CLASS=""
- FOR
- SET CLASS=$ORDER(CLS(CLASS))
- IF CLASS=""
- QUIT
- Begin DoDot:1
- +7 SET INACT=$PIECE(CLS(CLASS),U,5)
- SET ACT=$PIECE(CLS(CLASS),U,4)
- +8 ;quit if class has an inactive date before now
- IF INACT
- IF (INACT<%)
- QUIT
- +9 ;quit if class has no active date
- IF 'ACT
- QUIT
- +10 SET ORX("DT",9999999-ACT)=$PIECE(CLS(CLASS),U)_U_CLASS
- End DoDot:1
- +11 SET INVDT=""
- SET INVDT=$ORDER(ORX("DT",INVDT))
- +12 IF INVDT
- SET RESULT=ORX("DT",INVDT)
- +13 IF '$TEST
- SET RESULT="^No user classes found."
- +14 KILL %
- +15 QUIT RESULT
- DIVF(USER,ORN,ORNUM) ;ext funct rtns user's division value for ORB PROCESSING FLAG
- +1 NEW DIV,DIVF,MDIVF,EDIVF,DDIVF
- +2 IF +$GET(ORNUM)
- Begin DoDot:1
- +3 SET DIVF=""
- +4 SET DIV=$$ORDIV^ORB31(ORNUM)
- +5 IF +$GET(DIV)'>0
- QUIT
- +6 SET DIVF=$$GET^XPAR(DIV_";DIC(4,","ORB PROCESSING FLAG",ORN,"I")
- +7 IF $LENGTH(DIVF)
- SET DIVF=DIV_U_DIVF
- End DoDot:1
- QUIT DIVF
- +8 SET DIV=0
- SET (DIVF,MDIVF,EDIVF,DDIVF)=""
- +9 FOR
- SET DIV=$ORDER(^VA(200,USER,2,"B",DIV))
- IF +$GET(DIV)<1!(DIVF="M")
- QUIT
- Begin DoDot:1
- +10 SET DIVF=$$GET^XPAR(DIV_";DIC(4,","ORB PROCESSING FLAG",ORN,"I")
- +11 IF DIVF="M"
- SET MDIVF=DIV_U_DIVF
- +12 IF DIVF="E"
- SET EDIVF=DIV_U_DIVF
- +13 IF DIVF="D"
- SET DDIVF=DIV_U_DIVF
- End DoDot:1
- +14 IF $LENGTH(MDIVF)
- QUIT MDIVF
- +15 IF $LENGTH(EDIVF)
- QUIT EDIVF
- +16 IF $LENGTH(DDIVF)
- QUIT DDIVF
- +17 QUIT ""
