ORWU1 ;SLC/GRE - General Utilities for Windows Calls ;Aug 4, 2021@15:32:01
;;3.0;ORDER ENTRY/RESULTS REPORTING;**149,187,195,215,394,533,519,539,564**;Dec 17, 1997;Build 1
;
Q
;
NP1 ; Return a set of names from the NEW PERSON file.
; (PKS/8/5/2003: Now called by NEWPERS^ORWU; internal mods made.)
; (Keep GETCOS^ORWTPN up to date with matching logic/code, too.)
;
; PARAMS from NEWPERS^ORWU call:
; .ORY=returned list.
; ORDATE=Checks for an active person class on this date (optional).
; ORDIR=Direction to move through the x-ref with $O.
; ORFROM=Starting name for this set or, if ORSIM=true, the starting IEN. ** NSR 20110606/539 - Allow for name or IEN **.
; ORKEY=Screen users by security key (optional).
; ORVIZ=If true, includes RDV users; otherwise not (optional).
; ORSIM=If true, this indicates that this is a Similar Provider RPC call NSR#20110606/539
;
N ORDD,ORDIV,ORDUP,ORGOOD,ORI,ORIEN1,ORIEN2,ORLAST,ORMAX,ORMRK,ORMULTI,ORNPI,ORPREV,ORSRV,ORTTL,ORTERM,ORNOW
N ORFNM,ORFNMLEN,ORLNM,OPTIEN,ORDUPNM,A,S1 ;** NSR 20110606/539 - Add first and last names, first name length and OPTIEN it is the IEN to the OPTION file
S ORNOW=$P($$NOW^XLFDT(),".")
K ORTAB S S1=0 F S S1=$O(^ORD(101.13,S1)) Q:'S1 S A=$P($G(^ORD(101.13,S1,0)),"^") I A="COR"!(A="NVA") S ORTAB(A)=S1
S ORI=0,ORMAX=44,(ORLAST,ORPREV,ORDUPNM)="",ORKEY=$G(ORKEY),ORDATE=$G(ORDATE),ORSIM=$G(ORSIM) ; NSR 20110606/539 added ORSIM
S OPTIEN=$$LKOPT^XPDMENU("OR CPRS GUI CHART") ;Set IEN to option file NSR 20110606/539
S ORMULTI=$$ALL^VASITE ; IA# 10112. Do once at beginning of call.
I +ORSIM D ; ** NSR 20110606/539 - If ORSIM, ORFROM is IEN and needs to be changed to name. Also get first name, its length and last name **
.N LASTCHAR,ORFIEN,ORFROM1,XFNM,XFNMLEN
.S ORFIEN=ORFROM
.S (ORFROM,ORFROM1)=$P(^VA(200,ORFROM,0),U),$P(ORFROM,",",2)=$E($P(ORFROM,",",2),1,2)
.S ORFNM=$P(ORFROM,",",2),ORFNMLEN=$L(ORFNM),ORLNM=$P(ORFROM,",") ; ** NSR 20110606/539 - Add ORFNM, ORFNMLEN and ORLNM **
.I ORFNM]"" D
..S XFNM=$P(ORFROM,",",2),XFNMLEN=$L(XFNM),LASTCHAR=$C($A(XFNM,XFNMLEN)-1),XFNM=$E(XFNM,1,XFNMLEN-1)_LASTCHAR_$C(126)
..S $P(ORFROM,",",2)=XFNM
.S ORI=ORI+1,ORY(ORI)=ORFIEN_"^"_$$NAMEFMT^XLFNAME(ORFROM1,"F","DcMPC")
.S ORDUPNM(ORFIEN)=""
.S ORIEN2=ORFIEN
.;Using NP2 instead of NP4(0) in case duplicate (same but different) entry found later
.D NP2
E D
.S (ORFNM,ORFNMLEN,ORLNM)=""
;
; NP3 tag includes visitors, uses full "B" x-ref.
I +$G(ORVIZ)=1 D NP3(0) Q ; Use alt. version, skip rest.
; User requested ALL users, both active and inactive. Same call, but skip $$PROVIDER^XUSER screen
I +$G(ORALL)=1 D NP3(0) Q
;
F Q:ORI'<ORMAX S ORFROM=$O(^VA(200,"AUSER",ORFROM),ORDIR) Q:ORFROM=""!'$$CHKORSIM(ORSIM,ORFNM,ORFNMLEN,ORFROM,ORLNM) D ; NSR 20110606/539 - Check for quitting with ORSIM and names comparison
.S ORIEN1=""
.F S ORIEN1=$O(^VA(200,"AUSER",ORFROM,ORIEN1),ORDIR) Q:'ORIEN1 D
..S ORTERM=$$GET1^DIQ(200,ORIEN1,9.2,"I") I ORTERM]"",ORTERM'>ORNOW Q
..I $D(ORDUPNM(ORIEN1)) Q
..; NSR 20120101 Limit Signers by Tabs & Excluded User Class
..I '+$$CPRSTAB(ORIEN1,ORTAB("COR")),'+$$CPRSTAB(ORIEN1,ORTAB("NVA")) Q ; Check core tab & Non-VA tab access including effective date and expiration date
.. I OREXCLDE,$$CPRSTAB(ORIEN1,ORTAB("NVA")) Q ;If excluding users for additional signer, exclude NVA tab holders
..I +OREXCLDE,+$$USRCLASS(ORIEN1) Q ; Check Excluded User Class
..;
..I $L(ORKEY),'$D(^XUSEC(ORKEY,+ORIEN1)) Q ; Check for key?
..I ORDATE>0,$$GET^XUA4A72(ORIEN1,ORDATE)<1 Q ; Check date?
..I +$G(ORPDMP)=1,'$$ISAUTH^ORPDMP(+ORIEN1) Q ;For PDMP query form, filter out non-authorized users
..I '$$CPRSTAB(ORIEN1,ORTAB("NVA")),+$$ACCESS^XQCHK(ORIEN1,OPTIEN)=0 Q ;NSR 20110606/539
..I +ORI,+ORY(ORI)=ORIEN1 Q ; if the current IEN is already in list, quit
..S ORI=ORI+1,ORY(ORI)=ORIEN1_"^"_$$NAMEFMT^XLFNAME(ORFROM,"F","DcMPC")
..S ORDUP=0 ; Init flag, check dupe.
..I ($P(ORPREV_" "," ")=$P(ORFROM_" "," ")) S ORDUP=1
..;
..; Append Title if not duplicated:
..I 'ORDUP D
...S ORIEN2=ORIEN1
...D NP4(0) ; Get Title. *533 & NPI
...; add NPI data *533 ; ajb
...I ORTTL="" S ORY(ORI)=ORY(ORI)_U_ORNPI Q
...S ORY(ORI)=ORY(ORI)_U_"- "_ORTTL_ORNPI
..;
..; Get data in case of dupes:
..I ORDUP D
...S ORIEN2=ORLAST ; Prev IEN for NP2 call.
...;
...; Reset, use previous array element, call for extended data:
...S ORI=ORI-1,ORY(ORI)=$P(ORY(ORI),U)_U_$P(ORY(ORI),U,2) D NP2
...;
...; Then return to current user for second extended data call:
...S ORIEN2=ORIEN1,ORI=ORI+1 D NP2
..S ORLAST=ORIEN1,ORPREV=ORFROM ; Reassign vars for next pass.
;
Q
;
NP2 ; Retrieve subset of data for dupes in NP1.
; (Assumes certain vars already set/new'd in calling code.)
;
; Variables used:
; ORZ = Memory array storage variable.
; ORZERR = Error storage for LIST^DIC call.
;
N ORZ,ORZERR ; Initialize variables.
S ORDIV="" ; Reset each time.
D NP4(1) ; Get Title, Service/Section.
;
; For multi-divisional site, get Division if determinable:
I ORMULTI D
.D LIST^DIC(200.02,","_ORIEN2_",","@;.01;1","QP","","","","","","","ORZ","ORZERR")
.S (ORDD,ORGOOD)=0 ; Initialize variables.
.I $P(ORZ("DILIST",0),U)=0 Q ; Division not listed.
.I $P(ORZ("DILIST",0),U)=1 D Q ; Only one, so use it.
..S ORDD=$O(ORZ("DILIST",ORDD)) ; Get the node's entry.
..S ORDIV=$P(ORZ("DILIST",ORDD,0),U,2) ; Get actual name value. p394
.;
.; More than one Division entry, so:
.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,2),ORGOOD=1 Q ; Division text.
;
; add NPI information *533 ; ajb
; Append new pieces to array string:
S ORMRK=""
I (ORTTL="")&(ORSRV="")&(ORDIV="")&(ORNPI="") Q ; Nothing to append. add check for NPI
S ORY(ORI)=ORY(ORI)_U_"- " ; At least something exists.
I (ORTTL'="") S ORY(ORI)=ORY(ORI)_ORTTL,ORMRK=", " ; Title.
I (ORSRV'="") S ORY(ORI)=ORY(ORI)_ORMRK_ORSRV,ORMRK=", " ; Service.
I (ORDIV'="") S ORY(ORI)=ORY(ORI)_ORMRK_ORDIV ; Division.
I (ORNPI'="") S ORY(ORI)=ORY(ORI)_ORNPI ; NPI *533
;
Q
;
NP3(COSFLAG) ; Retrieve diff. data when all users are involved, using "B" x-ref.
;
; COSFLAG=If TRUE, called by ORWTPN.
; (Assumes certain vars already set/new'd in calling code.)
;
N ORNODE,COSQUIT
S COSQUIT=0 ; Flag used in section for COSFLAG.
;
F Q:ORI'<ORMAX S ORFROM=$O(^VA(200,"B",ORFROM),ORDIR) Q:ORFROM="" D
.S ORIEN1=""
.F S ORIEN1=$O(^VA(200,"B",ORFROM,ORIEN1),ORDIR) Q:'ORIEN1 D
..;
..; Screen default cosigner if appropriate (ORUSER set in ORWTPN):
..I COSFLAG D
...S COSQUIT=0
...I '$$SCRDFCS^TIULA3(ORUSER,ORIEN1) S COSFLAG=1 Q
...S ORNODE=$P($G(^VA(200,ORIEN1,0)),U)
...I '$L(ORNODE) S COSFLAG=1 Q
..I COSQUIT Q
..;
..I +$G(ORALL)=0,'$$PROVIDER^XUSER(ORIEN1,1) Q ; Terminated? Skip if ALL requested
..I ORDATE>0,$$GET^XUA4A72(ORIEN1,ORDATE)<1 Q ; Check date?
..I $L(ORKEY),'$D(^XUSEC(ORKEY,+ORIEN1)) Q ; Check for key?
..S ORI=ORI+1,ORY(ORI)=ORIEN1_"^"_$$NAMEFMT^XLFNAME(ORFROM,"F","DcMPC")
..S ORDUP=0 ; Init flag, check duplication.
..I ($P(ORPREV_" "," ")=$P(ORFROM_" "," ")) S ORDUP=1
..;
..; Append Title if not duplicated:
..I 'ORDUP D
...S ORIEN2=ORIEN1
...D NP4(0) ; Get Title.
...; add NPI data *533 ; ajb
...I ORTTL="" S ORY(ORI)=ORY(ORI)_U_ORNPI Q
...S ORY(ORI)=ORY(ORI)_U_"- "_ORTTL_ORNPI
..;
..; Get data in case of dupes:
..I ORDUP D
...S ORIEN2=ORLAST ; Set to prev. IEN for NP2.
...;
...; Reset, use previous array element, call for extended data:
...S ORI=ORI-1,ORY(ORI)=$P(ORY(ORI),U)_U_$P(ORY(ORI),U,2) D NP2
...;
...; Now return to current user for second extended data call:
...S ORIEN2=ORIEN1,ORI=ORI+1 D NP2
..S ORLAST=ORIEN1,ORPREV=ORFROM ; Reassign vars for next pass.
;
Q
;
NP4(ORSS) ; Retrieve Title or Title and Service/Section.
; (Assumes certain vars already set/new'd in calling code.)
;
; Passed variable ORSS: If true, get Service/Section also.
;
S (ORNPI,ORTTL,ORSRV)="" ; Init each time. *533
; DBIA# 4329:
S ORTTL=$P($G(^VA(200,ORIEN2,0)),U,9) ; Get Title pointer.
S ORNPI=+$$NPI^XUSNPI("Individual_ID",ORIEN2) ; Get NPI. *533 ICR#4532
S ORNPI=$S(ORNPI>0:" [NPI:"_ORNPI_"]",1:"")
I ORTTL<1 S ORTTL="" ; Reset var if none.
; DBIA# 1234:
I ORTTL>0 S ORTTL=$$TITLE^XLFSTR($G(^DIC(3.1,ORTTL,0))) ; Actual Title value. *533 title case
S ORSS=$G(ORSS)
I ORSS D ; Get Service/Section?
.; DBIA# 4329:
.S ORSRV=$P($G(^VA(200,ORIEN2,5)),U,1) ; Get S/S pointer.
.I ORSRV<1 S ORSRV="" ; Reset var if none.
.; DBIA# 4330:
.I ORSRV>0 S ORSRV=$$TITLE^XLFSTR($P($G(^DIC(49,ORSRV,0)),U)) ; Actual S/S value. *533 title case
;
Q
;
NAMECVT(Y,IEN) ; Returns text name(mixed-case) derived from IEN xref.
; GRE/2002
; PKS-12/20/2002 Tag not presently used.
; Y=Returned value, IEN=Internal number
N ORNAME
S IEN=IEN_","
S ORNAME=$$GET1^DIQ(200,IEN,20.2)
S Y=$$NAMEFMT^XLFNAME(.ORNAME,"F","DcMPC")
Q
;
DEFDIV(Y) ; Return user's default division, if specified.
;
; Variables used:
; ORDD = Default division.
; ORDIV = Division holder variable.
; ORGOOD = Flag for successful default division found.
; ORIEN = IEN of user.
; ORZ = Memory array storage variable.
; ORZERR = Error storage for LIST^DIC call.
; Y = Returned value.
;
N ORDD,ORDIV,ORGOOD,ORIEN,ORZ,ORZERR
;
S ORIEN=DUZ,ORDIV=""
S Y=0,(ORDD,ORGOOD)=0 ; Initialize variables.
;
; Get list of divisions from NEW PERSON file multiple:
D LIST^DIC(200.02,","_ORIEN_",","@;.01;1","QP","","","","","","","ORZ","ORZERR")
I $P(ORZ("DILIST",0),U)=0 Q ; No Divisions listed.
;
; Iterate through list:
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,2),ORGOOD=1 ; Division text.
.;
I (ORDIV="") Q ; Punt if no default division.
I $$UP^XLFSTR(ORDIV)="SALT LAKE CITY OIFO" S Y=1
;
Q
;
NEWLOC(Y,ORFROM,DIR) ; Return "CZ" locations from HOSPITAL LOCATION file.
; C=Clinics, Z=Other, screened by $$ACTLOC^ORWU.
; .Y=returned list, ORFROM=text to $O from, DIR=$O direction.
N I,IEN,CNT S I=0,CNT=44
F Q:I'<CNT S ORFROM=$O(^SC("B",ORFROM),DIR) Q:ORFROM="" D ; IA# 10040.
. S IEN="" F S IEN=$O(^SC("B",ORFROM,IEN),DIR) Q:'IEN D
. . Q:("C"'[$P($G(^SC(IEN,0)),U,3)!('$$ACTLOC^ORWU(IEN)))
. . S I=I+1,Y(I)=IEN_"^"_ORFROM
Q
;
CHKORSIM(ORSIM,ORFNM,ORFNMLEN,ORFROM,ORLNM) ; NSR 20110606/539 - Check if name complies with ORSIM flag and restrictions
I 'ORSIM Q 1 ; If 'ORSIM, no additional restrictions
I $E(ORFROM,1,$L(ORLNM))'=ORLNM Q 0 ; If last names don't match, quit now
I $E($P(ORFROM,",",2),1,ORFNMLEN)'=ORFNM Q 0 ; If first name portions don't match, quit now
Q 1 ; All checks passed
;
CPRSTAB(USER,TAB) ; NSR 20120101 - return 1 if users is ok to stay in list
; update 04/19/2021 to include NVA (Non-VA Providers) tab
; 1 - CPRS GUI "core" tabs.
; 2 - Reports tab.
; 3 - Non-VA Providers tab.
N ORRES,ORTAB,ORX S ORRES=0 ; result, default to 0
; TAB^EFFECTIVE DATE^EXPIRATION DATE
I '$D(^VA(200,USER,"ORD","B",TAB)) Q ORRES
S ORX=0 F S ORX=$O(^VA(200,USER,"ORD","B",TAB,ORX)) Q:'ORX D Q:ORRES
. S ORTAB=$G(^VA(200,USER,"ORD",ORX,0))
. ; evaluate COR or NVA tab, check effective date, check expiration date
. I DT'<$P(ORTAB,U,2),+$P(ORTAB,U,3)=0!(DT<$P(ORTAB,U,3)) S ORRES=1
Q ORRES
;
USRCLASS(USER) ; NSR 20120101
N ORLIST,ORQUIT,ORX
S ORQUIT=0
D GETLST^XPAR(.ORLIST,"SYS","OR CPRS USER CLASS EXCLUDE","I") ; IA# 2263
S ORX="" F S ORX=$O(ORLIST(ORX)) Q:'+ORX D
. I +$$ISA^USRLM(USER,ORLIST(ORX)) S ORQUIT=1 ; IA# 1544
Q ORQUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWU1 12535 printed Oct 16, 2024@18:38:15 Page 2
ORWU1 ;SLC/GRE - General Utilities for Windows Calls ;Aug 4, 2021@15:32:01
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**149,187,195,215,394,533,519,539,564**;Dec 17, 1997;Build 1
+2 ;
+3 QUIT
+4 ;
NP1 ; Return a set of names from the NEW PERSON file.
+1 ; (PKS/8/5/2003: Now called by NEWPERS^ORWU; internal mods made.)
+2 ; (Keep GETCOS^ORWTPN up to date with matching logic/code, too.)
+3 ;
+4 ; PARAMS from NEWPERS^ORWU call:
+5 ; .ORY=returned list.
+6 ; ORDATE=Checks for an active person class on this date (optional).
+7 ; ORDIR=Direction to move through the x-ref with $O.
+8 ; ORFROM=Starting name for this set or, if ORSIM=true, the starting IEN. ** NSR 20110606/539 - Allow for name or IEN **.
+9 ; ORKEY=Screen users by security key (optional).
+10 ; ORVIZ=If true, includes RDV users; otherwise not (optional).
+11 ; ORSIM=If true, this indicates that this is a Similar Provider RPC call NSR#20110606/539
+12 ;
+13 NEW ORDD,ORDIV,ORDUP,ORGOOD,ORI,ORIEN1,ORIEN2,ORLAST,ORMAX,ORMRK,ORMULTI,ORNPI,ORPREV,ORSRV,ORTTL,ORTERM,ORNOW
+14 ;** NSR 20110606/539 - Add first and last names, first name length and OPTIEN it is the IEN to the OPTION file
NEW ORFNM,ORFNMLEN,ORLNM,OPTIEN,ORDUPNM,A,S1
+15 SET ORNOW=$PIECE($$NOW^XLFDT(),".")
+16 KILL ORTAB
SET S1=0
FOR
SET S1=$ORDER(^ORD(101.13,S1))
if 'S1
QUIT
SET A=$PIECE($GET(^ORD(101.13,S1,0)),"^")
IF A="COR"!(A="NVA")
SET ORTAB(A)=S1
+17 ; NSR 20110606/539 added ORSIM
SET ORI=0
SET ORMAX=44
SET (ORLAST,ORPREV,ORDUPNM)=""
SET ORKEY=$GET(ORKEY)
SET ORDATE=$GET(ORDATE)
SET ORSIM=$GET(ORSIM)
+18 ;Set IEN to option file NSR 20110606/539
SET OPTIEN=$$LKOPT^XPDMENU("OR CPRS GUI CHART")
+19 ; IA# 10112. Do once at beginning of call.
SET ORMULTI=$$ALL^VASITE
+20 ; ** NSR 20110606/539 - If ORSIM, ORFROM is IEN and needs to be changed to name. Also get first name, its length and last name **
IF +ORSIM
Begin DoDot:1
+21 NEW LASTCHAR,ORFIEN,ORFROM1,XFNM,XFNMLEN
+22 SET ORFIEN=ORFROM
+23 SET (ORFROM,ORFROM1)=$PIECE(^VA(200,ORFROM,0),U)
SET $PIECE(ORFROM,",",2)=$EXTRACT($PIECE(ORFROM,",",2),1,2)
+24 ; ** NSR 20110606/539 - Add ORFNM, ORFNMLEN and ORLNM **
SET ORFNM=$PIECE(ORFROM,",",2)
SET ORFNMLEN=$LENGTH(ORFNM)
SET ORLNM=$PIECE(ORFROM,",")
+25 IF ORFNM]""
Begin DoDot:2
+26 SET XFNM=$PIECE(ORFROM,",",2)
SET XFNMLEN=$LENGTH(XFNM)
SET LASTCHAR=$CHAR($ASCII(XFNM,XFNMLEN)-1)
SET XFNM=$EXTRACT(XFNM,1,XFNMLEN-1)_LASTCHAR_$CHAR(126)
+27 SET $PIECE(ORFROM,",",2)=XFNM
End DoDot:2
+28 SET ORI=ORI+1
SET ORY(ORI)=ORFIEN_"^"_$$NAMEFMT^XLFNAME(ORFROM1,"F","DcMPC")
+29 SET ORDUPNM(ORFIEN)=""
+30 SET ORIEN2=ORFIEN
+31 ;Using NP2 instead of NP4(0) in case duplicate (same but different) entry found later
+32 DO NP2
End DoDot:1
+33 IF '$TEST
Begin DoDot:1
+34 SET (ORFNM,ORFNMLEN,ORLNM)=""
End DoDot:1
+35 ;
+36 ; NP3 tag includes visitors, uses full "B" x-ref.
+37 ; Use alt. version, skip rest.
IF +$GET(ORVIZ)=1
DO NP3(0)
QUIT
+38 ; User requested ALL users, both active and inactive. Same call, but skip $$PROVIDER^XUSER screen
+39 IF +$GET(ORALL)=1
DO NP3(0)
QUIT
+40 ;
+41 ; NSR 20110606/539 - Check for quitting with ORSIM and names comparison
FOR
if ORI'<ORMAX
QUIT
SET ORFROM=$ORDER(^VA(200,"AUSER",ORFROM),ORDIR)
if ORFROM=""!'$$CHKORSIM(ORSIM,ORFNM,ORFNMLEN,ORFROM,ORLNM)
QUIT
Begin DoDot:1
+42 SET ORIEN1=""
+43 FOR
SET ORIEN1=$ORDER(^VA(200,"AUSER",ORFROM,ORIEN1),ORDIR)
if 'ORIEN1
QUIT
Begin DoDot:2
+44 SET ORTERM=$$GET1^DIQ(200,ORIEN1,9.2,"I")
IF ORTERM]""
IF ORTERM'>ORNOW
QUIT
+45 IF $DATA(ORDUPNM(ORIEN1))
QUIT
+46 ; NSR 20120101 Limit Signers by Tabs & Excluded User Class
+47 ; Check core tab & Non-VA tab access including effective date and expiration date
IF '+$$CPRSTAB(ORIEN1,ORTAB("COR"))
IF '+$$CPRSTAB(ORIEN1,ORTAB("NVA"))
QUIT
+48 ;If excluding users for additional signer, exclude NVA tab holders
IF OREXCLDE
IF $$CPRSTAB(ORIEN1,ORTAB("NVA"))
QUIT
+49 ; Check Excluded User Class
IF +OREXCLDE
IF +$$USRCLASS(ORIEN1)
QUIT
+50 ;
+51 ; Check for key?
IF $LENGTH(ORKEY)
IF '$DATA(^XUSEC(ORKEY,+ORIEN1))
QUIT
+52 ; Check date?
IF ORDATE>0
IF $$GET^XUA4A72(ORIEN1,ORDATE)<1
QUIT
+53 ;For PDMP query form, filter out non-authorized users
IF +$GET(ORPDMP)=1
IF '$$ISAUTH^ORPDMP(+ORIEN1)
QUIT
+54 ;NSR 20110606/539
IF '$$CPRSTAB(ORIEN1,ORTAB("NVA"))
IF +$$ACCESS^XQCHK(ORIEN1,OPTIEN)=0
QUIT
+55 ; if the current IEN is already in list, quit
IF +ORI
IF +ORY(ORI)=ORIEN1
QUIT
+56 SET ORI=ORI+1
SET ORY(ORI)=ORIEN1_"^"_$$NAMEFMT^XLFNAME(ORFROM,"F","DcMPC")
+57 ; Init flag, check dupe.
SET ORDUP=0
+58 IF ($PIECE(ORPREV_" "," ")=$PIECE(ORFROM_" "," "))
SET ORDUP=1
+59 ;
+60 ; Append Title if not duplicated:
+61 IF 'ORDUP
Begin DoDot:3
+62 SET ORIEN2=ORIEN1
+63 ; Get Title. *533 & NPI
DO NP4(0)
+64 ; add NPI data *533 ; ajb
+65 IF ORTTL=""
SET ORY(ORI)=ORY(ORI)_U_ORNPI
QUIT
+66 SET ORY(ORI)=ORY(ORI)_U_"- "_ORTTL_ORNPI
End DoDot:3
+67 ;
+68 ; Get data in case of dupes:
+69 IF ORDUP
Begin DoDot:3
+70 ; Prev IEN for NP2 call.
SET ORIEN2=ORLAST
+71 ;
+72 ; Reset, use previous array element, call for extended data:
+73 SET ORI=ORI-1
SET ORY(ORI)=$PIECE(ORY(ORI),U)_U_$PIECE(ORY(ORI),U,2)
DO NP2
+74 ;
+75 ; Then return to current user for second extended data call:
+76 SET ORIEN2=ORIEN1
SET ORI=ORI+1
DO NP2
End DoDot:3
+77 ; Reassign vars for next pass.
SET ORLAST=ORIEN1
SET ORPREV=ORFROM
End DoDot:2
End DoDot:1
+78 ;
+79 QUIT
+80 ;
NP2 ; Retrieve subset of data for dupes in NP1.
+1 ; (Assumes certain vars already set/new'd in calling code.)
+2 ;
+3 ; Variables used:
+4 ; ORZ = Memory array storage variable.
+5 ; ORZERR = Error storage for LIST^DIC call.
+6 ;
+7 ; Initialize variables.
NEW ORZ,ORZERR
+8 ; Reset each time.
SET ORDIV=""
+9 ; Get Title, Service/Section.
DO NP4(1)
+10 ;
+11 ; For multi-divisional site, get Division if determinable:
+12 IF ORMULTI
Begin DoDot:1
+13 DO LIST^DIC(200.02,","_ORIEN2_",","@;.01;1","QP","","","","","","","ORZ","ORZERR")
+14 ; Initialize variables.
SET (ORDD,ORGOOD)=0
+15 ; Division not listed.
IF $PIECE(ORZ("DILIST",0),U)=0
QUIT
+16 ; Only one, so use it.
IF $PIECE(ORZ("DILIST",0),U)=1
Begin DoDot:2
+17 ; Get the node's entry.
SET ORDD=$ORDER(ORZ("DILIST",ORDD))
+18 ; Get actual name value. p394
SET ORDIV=$PIECE(ORZ("DILIST",ORDD,0),U,2)
End DoDot:2
QUIT
+19 ;
+20 ; More than one Division entry, so:
+21 FOR
SET ORDD=$ORDER(ORZ("DILIST",ORDD))
if +ORDD=0!'($LENGTH(ORDD))
QUIT
Begin DoDot:2
+22 ;
+23 ; See if current entry being processed is "Default" (done if so):
+24 ; Division text.
IF $PIECE(ORZ("DILIST",ORDD,0),U,3)["Y"
SET ORDIV=$PIECE(ORZ("DILIST",ORDD,0),U,2)
SET ORGOOD=1
QUIT
End DoDot:2
if ORGOOD
QUIT
End DoDot:1
+25 ;
+26 ; add NPI information *533 ; ajb
+27 ; Append new pieces to array string:
+28 SET ORMRK=""
+29 ; Nothing to append. add check for NPI
IF (ORTTL="")&(ORSRV="")&(ORDIV="")&(ORNPI="")
QUIT
+30 ; At least something exists.
SET ORY(ORI)=ORY(ORI)_U_"- "
+31 ; Title.
IF (ORTTL'="")
SET ORY(ORI)=ORY(ORI)_ORTTL
SET ORMRK=", "
+32 ; Service.
IF (ORSRV'="")
SET ORY(ORI)=ORY(ORI)_ORMRK_ORSRV
SET ORMRK=", "
+33 ; Division.
IF (ORDIV'="")
SET ORY(ORI)=ORY(ORI)_ORMRK_ORDIV
+34 ; NPI *533
IF (ORNPI'="")
SET ORY(ORI)=ORY(ORI)_ORNPI
+35 ;
+36 QUIT
+37 ;
NP3(COSFLAG) ; Retrieve diff. data when all users are involved, using "B" x-ref.
+1 ;
+2 ; COSFLAG=If TRUE, called by ORWTPN.
+3 ; (Assumes certain vars already set/new'd in calling code.)
+4 ;
+5 NEW ORNODE,COSQUIT
+6 ; Flag used in section for COSFLAG.
SET COSQUIT=0
+7 ;
+8 FOR
if ORI'<ORMAX
QUIT
SET ORFROM=$ORDER(^VA(200,"B",ORFROM),ORDIR)
if ORFROM=""
QUIT
Begin DoDot:1
+9 SET ORIEN1=""
+10 FOR
SET ORIEN1=$ORDER(^VA(200,"B",ORFROM,ORIEN1),ORDIR)
if 'ORIEN1
QUIT
Begin DoDot:2
+11 ;
+12 ; Screen default cosigner if appropriate (ORUSER set in ORWTPN):
+13 IF COSFLAG
Begin DoDot:3
+14 SET COSQUIT=0
+15 IF '$$SCRDFCS^TIULA3(ORUSER,ORIEN1)
SET COSFLAG=1
QUIT
+16 SET ORNODE=$PIECE($GET(^VA(200,ORIEN1,0)),U)
+17 IF '$LENGTH(ORNODE)
SET COSFLAG=1
QUIT
End DoDot:3
+18 IF COSQUIT
QUIT
+19 ;
+20 ; Terminated? Skip if ALL requested
IF +$GET(ORALL)=0
IF '$$PROVIDER^XUSER(ORIEN1,1)
QUIT
+21 ; Check date?
IF ORDATE>0
IF $$GET^XUA4A72(ORIEN1,ORDATE)<1
QUIT
+22 ; Check for key?
IF $LENGTH(ORKEY)
IF '$DATA(^XUSEC(ORKEY,+ORIEN1))
QUIT
+23 SET ORI=ORI+1
SET ORY(ORI)=ORIEN1_"^"_$$NAMEFMT^XLFNAME(ORFROM,"F","DcMPC")
+24 ; Init flag, check duplication.
SET ORDUP=0
+25 IF ($PIECE(ORPREV_" "," ")=$PIECE(ORFROM_" "," "))
SET ORDUP=1
+26 ;
+27 ; Append Title if not duplicated:
+28 IF 'ORDUP
Begin DoDot:3
+29 SET ORIEN2=ORIEN1
+30 ; Get Title.
DO NP4(0)
+31 ; add NPI data *533 ; ajb
+32 IF ORTTL=""
SET ORY(ORI)=ORY(ORI)_U_ORNPI
QUIT
+33 SET ORY(ORI)=ORY(ORI)_U_"- "_ORTTL_ORNPI
End DoDot:3
+34 ;
+35 ; Get data in case of dupes:
+36 IF ORDUP
Begin DoDot:3
+37 ; Set to prev. IEN for NP2.
SET ORIEN2=ORLAST
+38 ;
+39 ; Reset, use previous array element, call for extended data:
+40 SET ORI=ORI-1
SET ORY(ORI)=$PIECE(ORY(ORI),U)_U_$PIECE(ORY(ORI),U,2)
DO NP2
+41 ;
+42 ; Now return to current user for second extended data call:
+43 SET ORIEN2=ORIEN1
SET ORI=ORI+1
DO NP2
End DoDot:3
+44 ; Reassign vars for next pass.
SET ORLAST=ORIEN1
SET ORPREV=ORFROM
End DoDot:2
End DoDot:1
+45 ;
+46 QUIT
+47 ;
NP4(ORSS) ; Retrieve Title or Title and Service/Section.
+1 ; (Assumes certain vars already set/new'd in calling code.)
+2 ;
+3 ; Passed variable ORSS: If true, get Service/Section also.
+4 ;
+5 ; Init each time. *533
SET (ORNPI,ORTTL,ORSRV)=""
+6 ; DBIA# 4329:
+7 ; Get Title pointer.
SET ORTTL=$PIECE($GET(^VA(200,ORIEN2,0)),U,9)
+8 ; Get NPI. *533 ICR#4532
SET ORNPI=+$$NPI^XUSNPI("Individual_ID",ORIEN2)
+9 SET ORNPI=$SELECT(ORNPI>0:" [NPI:"_ORNPI_"]",1:"")
+10 ; Reset var if none.
IF ORTTL<1
SET ORTTL=""
+11 ; DBIA# 1234:
+12 ; Actual Title value. *533 title case
IF ORTTL>0
SET ORTTL=$$TITLE^XLFSTR($GET(^DIC(3.1,ORTTL,0)))
+13 SET ORSS=$GET(ORSS)
+14 ; Get Service/Section?
IF ORSS
Begin DoDot:1
+15 ; DBIA# 4329:
+16 ; Get S/S pointer.
SET ORSRV=$PIECE($GET(^VA(200,ORIEN2,5)),U,1)
+17 ; Reset var if none.
IF ORSRV<1
SET ORSRV=""
+18 ; DBIA# 4330:
+19 ; Actual S/S value. *533 title case
IF ORSRV>0
SET ORSRV=$$TITLE^XLFSTR($PIECE($GET(^DIC(49,ORSRV,0)),U))
End DoDot:1
+20 ;
+21 QUIT
+22 ;
NAMECVT(Y,IEN) ; Returns text name(mixed-case) derived from IEN xref.
+1 ; GRE/2002
+2 ; PKS-12/20/2002 Tag not presently used.
+3 ; Y=Returned value, IEN=Internal number
+4 NEW ORNAME
+5 SET IEN=IEN_","
+6 SET ORNAME=$$GET1^DIQ(200,IEN,20.2)
+7 SET Y=$$NAMEFMT^XLFNAME(.ORNAME,"F","DcMPC")
+8 QUIT
+9 ;
DEFDIV(Y) ; Return user's default division, if specified.
+1 ;
+2 ; Variables used:
+3 ; ORDD = Default division.
+4 ; ORDIV = Division holder variable.
+5 ; ORGOOD = Flag for successful default division found.
+6 ; ORIEN = IEN of user.
+7 ; ORZ = Memory array storage variable.
+8 ; ORZERR = Error storage for LIST^DIC call.
+9 ; Y = Returned value.
+10 ;
+11 NEW ORDD,ORDIV,ORGOOD,ORIEN,ORZ,ORZERR
+12 ;
+13 SET ORIEN=DUZ
SET ORDIV=""
+14 ; Initialize variables.
SET Y=0
SET (ORDD,ORGOOD)=0
+15 ;
+16 ; Get list of divisions from NEW PERSON file multiple:
+17 DO LIST^DIC(200.02,","_ORIEN_",","@;.01;1","QP","","","","","","","ORZ","ORZERR")
+18 ; No Divisions listed.
IF $PIECE(ORZ("DILIST",0),U)=0
QUIT
+19 ;
+20 ; Iterate through list:
+21 FOR
SET ORDD=$ORDER(ORZ("DILIST",ORDD))
if +ORDD=0!'($LENGTH(ORDD))
QUIT
Begin DoDot:1
+22 ;
+23 ; See if current entry being processed is "Default" (done if so):
+24 ; Division text.
IF $PIECE(ORZ("DILIST",ORDD,0),U,3)["Y"
SET ORDIV=$PIECE(ORZ("DILIST",ORDD,0),U,2)
SET ORGOOD=1
+25 ;
End DoDot:1
if ORGOOD
QUIT
+26 ; Punt if no default division.
IF (ORDIV="")
QUIT
+27 IF $$UP^XLFSTR(ORDIV)="SALT LAKE CITY OIFO"
SET Y=1
+28 ;
+29 QUIT
+30 ;
NEWLOC(Y,ORFROM,DIR) ; Return "CZ" locations from HOSPITAL LOCATION file.
+1 ; C=Clinics, Z=Other, screened by $$ACTLOC^ORWU.
+2 ; .Y=returned list, ORFROM=text to $O from, DIR=$O direction.
+3 NEW I,IEN,CNT
SET I=0
SET CNT=44
+4 ; IA# 10040.
FOR
if I'<CNT
QUIT
SET ORFROM=$ORDER(^SC("B",ORFROM),DIR)
if ORFROM=""
QUIT
Begin DoDot:1
+5 SET IEN=""
FOR
SET IEN=$ORDER(^SC("B",ORFROM,IEN),DIR)
if 'IEN
QUIT
Begin DoDot:2
+6 if ("C"'[$PIECE($GET(^SC(IEN,0)),U,3)!('$$ACTLOC^ORWU(IEN)))
QUIT
+7 SET I=I+1
SET Y(I)=IEN_"^"_ORFROM
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
CHKORSIM(ORSIM,ORFNM,ORFNMLEN,ORFROM,ORLNM) ; NSR 20110606/539 - Check if name complies with ORSIM flag and restrictions
+1 ; If 'ORSIM, no additional restrictions
IF 'ORSIM
QUIT 1
+2 ; If last names don't match, quit now
IF $EXTRACT(ORFROM,1,$LENGTH(ORLNM))'=ORLNM
QUIT 0
+3 ; If first name portions don't match, quit now
IF $EXTRACT($PIECE(ORFROM,",",2),1,ORFNMLEN)'=ORFNM
QUIT 0
+4 ; All checks passed
QUIT 1
+5 ;
CPRSTAB(USER,TAB) ; NSR 20120101 - return 1 if users is ok to stay in list
+1 ; update 04/19/2021 to include NVA (Non-VA Providers) tab
+2 ; 1 - CPRS GUI "core" tabs.
+3 ; 2 - Reports tab.
+4 ; 3 - Non-VA Providers tab.
+5 ; result, default to 0
NEW ORRES,ORTAB,ORX
SET ORRES=0
+6 ; TAB^EFFECTIVE DATE^EXPIRATION DATE
+7 IF '$DATA(^VA(200,USER,"ORD","B",TAB))
QUIT ORRES
+8 SET ORX=0
FOR
SET ORX=$ORDER(^VA(200,USER,"ORD","B",TAB,ORX))
if 'ORX
QUIT
Begin DoDot:1
+9 SET ORTAB=$GET(^VA(200,USER,"ORD",ORX,0))
+10 ; evaluate COR or NVA tab, check effective date, check expiration date
+11 IF DT'<$PIECE(ORTAB,U,2)
IF +$PIECE(ORTAB,U,3)=0!(DT<$PIECE(ORTAB,U,3))
SET ORRES=1
End DoDot:1
if ORRES
QUIT
+12 QUIT ORRES
+13 ;
USRCLASS(USER) ; NSR 20120101
+1 NEW ORLIST,ORQUIT,ORX
+2 SET ORQUIT=0
+3 ; IA# 2263
DO GETLST^XPAR(.ORLIST,"SYS","OR CPRS USER CLASS EXCLUDE","I")
+4 SET ORX=""
FOR
SET ORX=$ORDER(ORLIST(ORX))
if '+ORX
QUIT
Begin DoDot:1
+5 ; IA# 1544
IF +$$ISA^USRLM(USER,ORLIST(ORX))
SET ORQUIT=1
End DoDot:1
+6 QUIT ORQUIT
