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

ORWU2.m

Go to the documentation of this file. 
  1. ORWU2 ; SLC/JEH,AJB - General Utilities for Windows Calls ;02/09/23  07:26
  1.  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**243,533,539,596**;Dec 17, 1997;Build 7
  1.  ;
  1.  ; External reference to $$REQCOSIG^TIULP supported by IA 2322
  1.  ; External reference to $$ISA^USRLM supported by IA 1544
  1.  ;
  1.  Q
  1. COSIGNER(ORY,ORFROM,ORDIR,ORDATE,ORTIUTYP,ORTIUDA,ORSIM) ; Return a set of names from the NEW PERSON file.
  1.  ; (Set up for the DC Summary)
  1.  ; (to use TIU doc requirments and USR PROVIDER)
  1.  ;
  1.  ; PARAMS from ORWU2 COSIGNER RPC call:
  1.  ;  .ORY=returned list.
  1.  ;  ORFROM=Starting name for this set.
  1.  ;  ORDIR=Direction to move through the x-ref with $O.
  1.  ;  ORDATE=Checks for an USR PROVIDER on this date (optional).
  1.  ;  ORTIUTYP is + of the 0 node of the 8925 docmt.
  1.  ;  ORTIUDA is the docmt IEN.
  1.  ;  ORSIM = If true, this indicates that this is a Similar Provider RPC call NSR#20110606 (539)
  1.  ;
  1.  ; *596 ajb
  1.  ; ORTIUTYP is always passed in as 0 & ORTIUDA  is the IEN of File #8925.1 [document definition]
  1.  I $$GET^XPAR("SYS","ORNEWPERS ACTIVE") D  Q  ; use new entry point^routine only if value is YES (default is YES)
  1.  . N I,PARAMS,PRM S PARAMS("HELP")=0,PRM(0)="FROM^DIR^DATE^TIUDA^TYPE^SPN"
  1.  . S PRM=$P($P($P($T(COSIGNER),"(",2),")"),",",2,$L($P($P($T(COSIGNER),"(",2),")"))) ; set string of parameters from NEWPERS
  1.  . F I=1:1:$L(PRM,",") S PARAMS($P(PRM(0),U,I))=$G(@($P(PRM,",",I))) ;                 set variables to pass by reference
  1.  . D NEWPERSON^ORNEWPERS(.ORY,.PARAMS)
  1.  ; *596 ajb
  1.  ;
  1.  N ORDD,ORDIV,ORDUP,ORGOOD,ORI,ORIEN1,ORIEN2,ORLAST,ORMAX,ORMRK,ORMULTI,ORNPI,ORPREV,ORSRV,ORTTL,ORERR
  1.  N ORFNM,ORFNMLEN,ORLNM,OPTIEN,ORDUPNM ; Add first and last names, the provider IEN and first name length
  1.  S ORI=0,ORMAX=44,(ORLAST,ORPREV,ORDUPNM)="",ORDATE=$G(ORDATE),ORSIM=$G(ORSIM)
  1.  S OPTIEN=$$LKOPT^XPDMENU("OR CPRS GUI CHART") ;Set IEN to option file for GUI Chart for Similar Provider calls
  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 COS2 instead of COS4(0) in case duplicate (same but different) entry found later
  1.  .D COS2
  1.  E  D
  1.  .S (ORFNM,ORFNMLEN,ORLNM)=""
  1.  ;
  1. ND I +$G(ORTIUDA) S ORTIUTYP=+$G(^TIU(8925,+$G(ORTIUDA),0))
  1.  ;
  1.  F  Q:ORI'<ORMAX  S ORFROM=$O(^VA(200,"AUSER",ORFROM),ORDIR) Q:ORFROM=""!'$$CHKORSIM(ORSIM,ORFNM,ORFNMLEN,ORFROM,ORLNM)  D  ;Check for quitting with ORSIM and names comparison (539)
  1.  .S ORIEN1=""
  1.  .F  S ORIEN1=$O(^VA(200,"AUSER",ORFROM,ORIEN1),ORDIR) Q:'ORIEN1  D
  1.  ..I $D(ORDUPNM(ORIEN1)) Q
  1.  ..I '$$PROVIDER^XUSER(ORIEN1,1) Q   ; Terminated?
  1.  ..I '$$ISA^USRLM(+ORIEN1,"PROVIDER",.ORERR,ORDATE) Q  ;(USR PROVIDER CLASS CHECK?)
  1. TIU .. I $$REQCOSIG^TIULP(ORTIUTYP,ORTIUDA,ORIEN1,ORDATE) Q  ; User requiers cosigner
  1.  ..I ORSIM,('+$$ACCESS^XQCHK(ORIEN1,OPTIEN)!'$$FIND1^DIC(200.010113,","_ORIEN1_",","","COR")) Q    ;Check if Similar Provider call
  1.  ..;I ($L(ORKEY)),(ORKEY'="COSIGNER"),('$D(^XUSEC(ORKEY,+ORIEN1))) Q       ; Check for key?
  1.  ..;I ORDATE>0,$$GET^XUA4A72(ORIEN1,ORDATE)<1 Q    ; Check date?
  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 COS4(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.  ...I ORTTL="" Q
  1.  ...S ORY(ORI)=ORY(ORI)_U_"- "_ORTTL
  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 COS2
  1.  ...;
  1.  ...; Then return to current user for second extended data call:
  1.  ...S ORIEN2=ORIEN1,ORI=ORI+1  D COS2
  1.  ..S ORLAST=ORIEN1,ORPREV=ORFROM        ; Reassign vars for next pass.
  1.  ;
  1. END Q
  1.  ;
  1. COS2 ; Retrieve subset of data for dupes in COSIGNER.
  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 COS4(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(ORDD,U,2)                 ; Get actual name value.
  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.  ; Append new pieces to array string:
  1.  S ORMRK=""
  1.  I (ORTTL="")&(ORSRV="")&(ORDIV="")&(ORNPI="")  Q  ; Nothing to append.
  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.  ;
  1. COS4(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.
  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.
  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.
  1.  ;
  1.  Q
  1.  ;
  1. CHKORSIM(ORSIM,ORFNM,ORFNMLEN,ORFROM,ORLNM) ; If this is a Similiar Provider call check for matching names - 539
  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