Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ORWU1

ORWU1.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. Q
  1. ;
  1. NP1 ; Return a set of names from the NEW PERSON file.
  1. ; (PKS/8/5/2003: Now called by NEWPERS^ORWU; internal mods made.)
  1. ; (Keep GETCOS^ORWTPN up to date with matching logic/code, too.)
  1. ;
  1. ; PARAMS from NEWPERS^ORWU call:
  1. ; .ORY=returned list.
  1. ; ORDATE=Checks for an active person class on this date (optional).
  1. ; ORDIR=Direction to move through the x-ref with $O.
  1. ; ORFROM=Starting name for this set or, if ORSIM=true, the starting IEN. ** NSR 20110606/539 - Allow for name or IEN **.
  1. ; ORKEY=Screen users by security key (optional).
  1. ; ORVIZ=If true, includes RDV users; otherwise not (optional).
  1. ; ORSIM=If true, this indicates that this is a Similar Provider RPC call NSR#20110606/539
  1. ;
  1. N ORDD,ORDIV,ORDUP,ORGOOD,ORI,ORIEN1,ORIEN2,ORLAST,ORMAX,ORMRK,ORMULTI,ORNPI,ORPREV,ORSRV,ORTTL,ORTERM,ORNOW
  1. 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
  1. S ORNOW=$P($$NOW^XLFDT(),".")
  1. 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
  1. S ORI=0,ORMAX=44,(ORLAST,ORPREV,ORDUPNM)="",ORKEY=$G(ORKEY),ORDATE=$G(ORDATE),ORSIM=$G(ORSIM) ; NSR 20110606/539 added ORSIM
  1. S OPTIEN=$$LKOPT^XPDMENU("OR CPRS GUI CHART") ;Set IEN to option file NSR 20110606/539
  1. S ORMULTI=$$ALL^VASITE ; IA# 10112. Do once at beginning of call.
  1. 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 **
  1. .N LASTCHAR,ORFIEN,ORFROM1,XFNM,XFNMLEN
  1. .S ORFIEN=ORFROM
  1. .S (ORFROM,ORFROM1)=$P(^VA(200,ORFROM,0),U),$P(ORFROM,",",2)=$E($P(ORFROM,",",2),1,2)
  1. .S ORFNM=$P(ORFROM,",",2),ORFNMLEN=$L(ORFNM),ORLNM=$P(ORFROM,",") ; ** NSR 20110606/539 - Add ORFNM, ORFNMLEN and ORLNM **
  1. .I ORFNM]"" D
  1. ..S XFNM=$P(ORFROM,",",2),XFNMLEN=$L(XFNM),LASTCHAR=$C($A(XFNM,XFNMLEN)-1),XFNM=$E(XFNM,1,XFNMLEN-1)_LASTCHAR_$C(126)
  1. ..S $P(ORFROM,",",2)=XFNM
  1. .S ORI=ORI+1,ORY(ORI)=ORFIEN_"^"_$$NAMEFMT^XLFNAME(ORFROM1,"F","DcMPC")
  1. .S ORDUPNM(ORFIEN)=""
  1. .S ORIEN2=ORFIEN
  1. .;Using NP2 instead of NP4(0) in case duplicate (same but different) entry found later
  1. .D NP2
  1. E D
  1. .S (ORFNM,ORFNMLEN,ORLNM)=""
  1. ;
  1. ; NP3 tag includes visitors, uses full "B" x-ref.
  1. I +$G(ORVIZ)=1 D NP3(0) Q ; Use alt. version, skip rest.
  1. ; User requested ALL users, both active and inactive. Same call, but skip $$PROVIDER^XUSER screen
  1. I +$G(ORALL)=1 D NP3(0) Q
  1. ;
  1. 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
  1. .S ORIEN1=""
  1. .F S ORIEN1=$O(^VA(200,"AUSER",ORFROM,ORIEN1),ORDIR) Q:'ORIEN1 D
  1. ..S ORTERM=$$GET1^DIQ(200,ORIEN1,9.2,"I") I ORTERM]"",ORTERM'>ORNOW Q
  1. ..I $D(ORDUPNM(ORIEN1)) Q
  1. ..; NSR 20120101 Limit Signers by Tabs & Excluded User Class
  1. ..I '+$$CPRSTAB(ORIEN1,ORTAB("COR")),'+$$CPRSTAB(ORIEN1,ORTAB("NVA")) Q ; Check core tab & Non-VA tab access including effective date and expiration date
  1. .. I OREXCLDE,$$CPRSTAB(ORIEN1,ORTAB("NVA")) Q ;If excluding users for additional signer, exclude NVA tab holders
  1. ..I +OREXCLDE,+$$USRCLASS(ORIEN1) Q ; Check Excluded User Class
  1. ..;
  1. ..I $L(ORKEY),'$D(^XUSEC(ORKEY,+ORIEN1)) Q ; Check for key?
  1. ..I ORDATE>0,$$GET^XUA4A72(ORIEN1,ORDATE)<1 Q ; Check date?
  1. ..I +$G(ORPDMP)=1,'$$ISAUTH^ORPDMP(+ORIEN1) Q ;For PDMP query form, filter out non-authorized users
  1. ..I '$$CPRSTAB(ORIEN1,ORTAB("NVA")),+$$ACCESS^XQCHK(ORIEN1,OPTIEN)=0 Q ;NSR 20110606/539
  1. ..I +ORI,+ORY(ORI)=ORIEN1 Q ; if the current IEN is already in list, quit
  1. ..S ORI=ORI+1,ORY(ORI)=ORIEN1_"^"_$$NAMEFMT^XLFNAME(ORFROM,"F","DcMPC")
  1. ..S ORDUP=0 ; Init flag, check dupe.
  1. ..I ($P(ORPREV_" "," ")=$P(ORFROM_" "," ")) S ORDUP=1
  1. ..;
  1. ..; Append Title if not duplicated:
  1. ..I 'ORDUP D
  1. ...S ORIEN2=ORIEN1
  1. ...D NP4(0) ; Get Title. *533 & NPI
  1. ...; add NPI data *533 ; ajb
  1. ...I ORTTL="" S ORY(ORI)=ORY(ORI)_U_ORNPI Q
  1. ...S ORY(ORI)=ORY(ORI)_U_"- "_ORTTL_ORNPI
  1. ..;
  1. ..; Get data in case of dupes:
  1. ..I ORDUP D
  1. ...S ORIEN2=ORLAST ; Prev IEN for NP2 call.
  1. ...;
  1. ...; Reset, use previous array element, call for extended data:
  1. ...S ORI=ORI-1,ORY(ORI)=$P(ORY(ORI),U)_U_$P(ORY(ORI),U,2) D NP2
  1. ...;
  1. ...; Then return to current user for second extended data call:
  1. ...S ORIEN2=ORIEN1,ORI=ORI+1 D NP2
  1. ..S ORLAST=ORIEN1,ORPREV=ORFROM ; Reassign vars for next pass.
  1. ;
  1. Q
  1. ;
  1. NP2 ; Retrieve subset of data for dupes in NP1.
  1. ; (Assumes certain vars already set/new'd in calling code.)
  1. ;
  1. ; Variables used:
  1. ; ORZ = Memory array storage variable.
  1. ; ORZERR = Error storage for LIST^DIC call.
  1. ;
  1. N ORZ,ORZERR ; Initialize variables.
  1. S ORDIV="" ; Reset each time.
  1. D NP4(1) ; Get Title, Service/Section.
  1. ;
  1. ; For multi-divisional site, get Division if determinable:
  1. I ORMULTI D
  1. .D LIST^DIC(200.02,","_ORIEN2_",","@;.01;1","QP","","","","","","","ORZ","ORZERR")
  1. .S (ORDD,ORGOOD)=0 ; Initialize variables.
  1. .I $P(ORZ("DILIST",0),U)=0 Q ; Division not listed.
  1. .I $P(ORZ("DILIST",0),U)=1 D Q ; Only one, so use it.
  1. ..S ORDD=$O(ORZ("DILIST",ORDD)) ; Get the node's entry.
  1. ..S ORDIV=$P(ORZ("DILIST",ORDD,0),U,2) ; Get actual name value. p394
  1. .;
  1. .; More than one Division entry, so:
  1. .F S ORDD=$O(ORZ("DILIST",ORDD)) Q:+ORDD=0!'($L(ORDD)) D Q:ORGOOD
  1. ..;
  1. ..; See if current entry being processed is "Default" (done if so):
  1. ..I $P(ORZ("DILIST",ORDD,0),U,3)["Y" S ORDIV=$P(ORZ("DILIST",ORDD,0),U,2),ORGOOD=1 Q ; Division text.
  1. ;
  1. ; add NPI information *533 ; ajb
  1. ; Append new pieces to array string:
  1. S ORMRK=""
  1. I (ORTTL="")&(ORSRV="")&(ORDIV="")&(ORNPI="") Q ; Nothing to append. add check for NPI
  1. S ORY(ORI)=ORY(ORI)_U_"- " ; At least something exists.
  1. I (ORTTL'="") S ORY(ORI)=ORY(ORI)_ORTTL,ORMRK=", " ; Title.
  1. I (ORSRV'="") S ORY(ORI)=ORY(ORI)_ORMRK_ORSRV,ORMRK=", " ; Service.
  1. I (ORDIV'="") S ORY(ORI)=ORY(ORI)_ORMRK_ORDIV ; Division.
  1. I (ORNPI'="") S ORY(ORI)=ORY(ORI)_ORNPI ; NPI *533
  1. ;
  1. Q
  1. ;
  1. NP3(COSFLAG) ; Retrieve diff. data when all users are involved, using "B" x-ref.
  1. ;
  1. ; COSFLAG=If TRUE, called by ORWTPN.
  1. ; (Assumes certain vars already set/new'd in calling code.)
  1. ;
  1. N ORNODE,COSQUIT
  1. S COSQUIT=0 ; Flag used in section for COSFLAG.
  1. ;
  1. F Q:ORI'<ORMAX S ORFROM=$O(^VA(200,"B",ORFROM),ORDIR) Q:ORFROM="" D
  1. .S ORIEN1=""
  1. .F S ORIEN1=$O(^VA(200,"B",ORFROM,ORIEN1),ORDIR) Q:'ORIEN1 D
  1. ..;
  1. ..; Screen default cosigner if appropriate (ORUSER set in ORWTPN):
  1. ..I COSFLAG D
  1. ...S COSQUIT=0
  1. ...I '$$SCRDFCS^TIULA3(ORUSER,ORIEN1) S COSFLAG=1 Q
  1. ...S ORNODE=$P($G(^VA(200,ORIEN1,0)),U)
  1. ...I '$L(ORNODE) S COSFLAG=1 Q
  1. ..I COSQUIT Q
  1. ..;
  1. ..I +$G(ORALL)=0,'$$PROVIDER^XUSER(ORIEN1,1) Q ; Terminated? Skip if ALL requested
  1. ..I ORDATE>0,$$GET^XUA4A72(ORIEN1,ORDATE)<1 Q ; Check date?
  1. ..I $L(ORKEY),'$D(^XUSEC(ORKEY,+ORIEN1)) Q ; Check for key?
  1. ..S ORI=ORI+1,ORY(ORI)=ORIEN1_"^"_$$NAMEFMT^XLFNAME(ORFROM,"F","DcMPC")
  1. ..S ORDUP=0 ; Init flag, check duplication.
  1. ..I ($P(ORPREV_" "," ")=$P(ORFROM_" "," ")) S ORDUP=1
  1. ..;
  1. ..; Append Title if not duplicated:
  1. ..I 'ORDUP D
  1. ...S ORIEN2=ORIEN1
  1. ...D NP4(0) ; Get Title.
  1. ...; add NPI data *533 ; ajb
  1. ...I ORTTL="" S ORY(ORI)=ORY(ORI)_U_ORNPI Q
  1. ...S ORY(ORI)=ORY(ORI)_U_"- "_ORTTL_ORNPI
  1. ..;
  1. ..; Get data in case of dupes:
  1. ..I ORDUP D
  1. ...S ORIEN2=ORLAST ; Set to prev. IEN for NP2.
  1. ...;
  1. ...; Reset, use previous array element, call for extended data:
  1. ...S ORI=ORI-1,ORY(ORI)=$P(ORY(ORI),U)_U_$P(ORY(ORI),U,2) D NP2
  1. ...;
  1. ...; Now return to current user for second extended data call:
  1. ...S ORIEN2=ORIEN1,ORI=ORI+1 D NP2
  1. ..S ORLAST=ORIEN1,ORPREV=ORFROM ; Reassign vars for next pass.
  1. ;
  1. Q
  1. ;
  1. NP4(ORSS) ; Retrieve Title or Title and Service/Section.
  1. ; (Assumes certain vars already set/new'd in calling code.)
  1. ;
  1. ; Passed variable ORSS: If true, get Service/Section also.
  1. ;
  1. S (ORNPI,ORTTL,ORSRV)="" ; Init each time. *533
  1. ; DBIA# 4329:
  1. S ORTTL=$P($G(^VA(200,ORIEN2,0)),U,9) ; Get Title pointer.
  1. S ORNPI=+$$NPI^XUSNPI("Individual_ID",ORIEN2) ; Get NPI. *533 ICR#4532
  1. S ORNPI=$S(ORNPI>0:" [NPI:"_ORNPI_"]",1:"")
  1. I ORTTL<1 S ORTTL="" ; Reset var if none.
  1. ; DBIA# 1234:
  1. I ORTTL>0 S ORTTL=$$TITLE^XLFSTR($G(^DIC(3.1,ORTTL,0))) ; Actual Title value. *533 title case
  1. S ORSS=$G(ORSS)
  1. I ORSS D ; Get Service/Section?
  1. .; DBIA# 4329:
  1. .S ORSRV=$P($G(^VA(200,ORIEN2,5)),U,1) ; Get S/S pointer.
  1. .I ORSRV<1 S ORSRV="" ; Reset var if none.
  1. .; DBIA# 4330:
  1. .I ORSRV>0 S ORSRV=$$TITLE^XLFSTR($P($G(^DIC(49,ORSRV,0)),U)) ; Actual S/S value. *533 title case
  1. ;
  1. Q
  1. ;
  1. NAMECVT(Y,IEN) ; Returns text name(mixed-case) derived from IEN xref.
  1. ; GRE/2002
  1. ; PKS-12/20/2002 Tag not presently used.
  1. ; Y=Returned value, IEN=Internal number
  1. N ORNAME
  1. S IEN=IEN_","
  1. S ORNAME=$$GET1^DIQ(200,IEN,20.2)
  1. S Y=$$NAMEFMT^XLFNAME(.ORNAME,"F","DcMPC")
  1. Q
  1. ;
  1. DEFDIV(Y) ; Return user's default division, if specified.
  1. ;
  1. ; Variables used:
  1. ; ORDD = Default division.
  1. ; ORDIV = Division holder variable.
  1. ; ORGOOD = Flag for successful default division found.
  1. ; ORIEN = IEN of user.
  1. ; ORZ = Memory array storage variable.
  1. ; ORZERR = Error storage for LIST^DIC call.
  1. ; Y = Returned value.
  1. ;
  1. N ORDD,ORDIV,ORGOOD,ORIEN,ORZ,ORZERR
  1. ;
  1. S ORIEN=DUZ,ORDIV=""
  1. S Y=0,(ORDD,ORGOOD)=0 ; Initialize variables.
  1. ;
  1. ; Get list of divisions from NEW PERSON file multiple:
  1. D LIST^DIC(200.02,","_ORIEN_",","@;.01;1","QP","","","","","","","ORZ","ORZERR")
  1. I $P(ORZ("DILIST",0),U)=0 Q ; No Divisions listed.
  1. ;
  1. ; Iterate through list:
  1. F S ORDD=$O(ORZ("DILIST",ORDD)) Q:+ORDD=0!'($L(ORDD)) D Q:ORGOOD
  1. .;
  1. .; See if current entry being processed is "Default" (done if so):
  1. .I $P(ORZ("DILIST",ORDD,0),U,3)["Y" S ORDIV=$P(ORZ("DILIST",ORDD,0),U,2),ORGOOD=1 ; Division text.
  1. .;
  1. I (ORDIV="") Q ; Punt if no default division.
  1. I $$UP^XLFSTR(ORDIV)="SALT LAKE CITY OIFO" S Y=1
  1. ;
  1. Q
  1. ;
  1. NEWLOC(Y,ORFROM,DIR) ; Return "CZ" locations from HOSPITAL LOCATION file.
  1. ; C=Clinics, Z=Other, screened by $$ACTLOC^ORWU.
  1. ; .Y=returned list, ORFROM=text to $O from, DIR=$O direction.
  1. N I,IEN,CNT S I=0,CNT=44
  1. F Q:I'<CNT S ORFROM=$O(^SC("B",ORFROM),DIR) Q:ORFROM="" D ; IA# 10040.
  1. . S IEN="" F S IEN=$O(^SC("B",ORFROM,IEN),DIR) Q:'IEN D
  1. . . Q:("C"'[$P($G(^SC(IEN,0)),U,3)!('$$ACTLOC^ORWU(IEN)))
  1. . . S I=I+1,Y(I)=IEN_"^"_ORFROM
  1. Q
  1. ;
  1. CHKORSIM(ORSIM,ORFNM,ORFNMLEN,ORFROM,ORLNM) ; NSR 20110606/539 - Check if name complies with ORSIM flag and restrictions
  1. I 'ORSIM Q 1 ; If 'ORSIM, no additional restrictions
  1. I $E(ORFROM,1,$L(ORLNM))'=ORLNM Q 0 ; If last names don't match, quit now
  1. I $E($P(ORFROM,",",2),1,ORFNMLEN)'=ORFNM Q 0 ; If first name portions don't match, quit now
  1. Q 1 ; All checks passed
  1. ;
  1. 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
  1. ; 1 - CPRS GUI "core" tabs.
  1. ; 2 - Reports tab.
  1. ; 3 - Non-VA Providers tab.
  1. N ORRES,ORTAB,ORX S ORRES=0 ; result, default to 0
  1. ; TAB^EFFECTIVE DATE^EXPIRATION DATE
  1. I '$D(^VA(200,USER,"ORD","B",TAB)) Q ORRES
  1. S ORX=0 F S ORX=$O(^VA(200,USER,"ORD","B",TAB,ORX)) Q:'ORX D Q:ORRES
  1. . S ORTAB=$G(^VA(200,USER,"ORD",ORX,0))
  1. . ; evaluate COR or NVA tab, check effective date, check expiration date
  1. . I DT'<$P(ORTAB,U,2),+$P(ORTAB,U,3)=0!(DT<$P(ORTAB,U,3)) S ORRES=1
  1. Q ORRES
  1. ;
  1. USRCLASS(USER) ; NSR 20120101
  1. N ORLIST,ORQUIT,ORX
  1. S ORQUIT=0
  1. D GETLST^XPAR(.ORLIST,"SYS","OR CPRS USER CLASS EXCLUDE","I") ; IA# 2263
  1. S ORX="" F S ORX=$O(ORLIST(ORX)) Q:'+ORX D
  1. . I +$$ISA^USRLM(USER,ORLIST(ORX)) S ORQUIT=1 ; IA# 1544
  1. Q ORQUIT