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

BGOPFUTL.m

Go to the documentation of this file. 
  1. BGOPFUTL ; MSC/IND/DKM - Preference Management ;14-Jul-2014 11:05;du
  1.  ;;1.1;BGO COMPONENTS;**3,13,14**;Mar 20, 2007;Build 1
  1.  ; Add or remove a manager from a category
  1.  ;  INP = Category IEN [1] ^ Manager IEN [2] ^ Add [3]
  1.  ;  SFN = Item subfile #
  1. SETMGR(RET,INP,SFN) ;EP
  1.  N CAT,MGR,ADD,FDA,GBL
  1.  I $G(INP)="" S RET=$$ERR^BGOUTL(1008) Q
  1.  S CAT=+INP
  1.  I 'CAT S RET=$$ERR^BGOUTL(1018) Q
  1.  S MGR=$P(INP,U,2)
  1.  I 'MGR S RET=$$ERR^BGOUTL(1031) Q
  1.  S ADD=$P(INP,U,3)
  1.  I ADD="" S RET=$$ERR^BGOUTL(1032) Q
  1.  S RET=$$ITEMROOT(SFN,CAT,.GBL)
  1.  Q:RET
  1.  I '$D(@GBL@(MGR,0))'='ADD D
  1.  .S FDA(SFN,$S(ADD:"+1",1:MGR)_","_CAT_",",.01)=$S(ADD:"`"_MGR,1:"@")
  1.  .S RET=$$UPDATE^BGOUTL(.FDA,"E")
  1.  Q
  1.  ; Set display name for a preference
  1.  ;  INP = Category IEN [1] ^ Item IEN [2] ^ Display Name [3]
  1.  ;  SFN = Item subfile #
  1. SETNAME(RET,INP,SFN) ;EP
  1.  N ITM,CAT,NAME,FDA
  1.  S CAT=+INP
  1.  I 'CAT S RET=$$ERR^BGOUTL(1018) Q
  1.  S ITM=$P(INP,U,2)
  1.  I 'ITM S RET=$$ERR^BGOUTL(1033) Q
  1.  S NAME=$P(INP,U,3)
  1.  I NAME="" S RET=$$ERR^BGOUTL(1034) Q
  1.  S FDA(SFN,ITM_","_CAT_",",.02)=NAME
  1.  S RET=$$UPDATE^BGOUTL(.FDA)
  1.  Q
  1.  ; Set frequency for a CPT code
  1.  ;  INP = Category IEN [1] ^ Item Value (defaults to all) [2] ^ Increment [3] ^ Frequency [4]
  1.  ;  SFN = Item subfile #
  1. SETFREQ(RET,INP,SFN) ;EP
  1.  N CAT,CNT,ITM,VAL,INC,DA,FDA,GBL
  1.  S RET=""
  1.  S CAT=+INP
  1.  I 'CAT S RET=$$ERR^BGOUTL(1018) Q
  1.  S ITM=$P(INP,U,2)
  1.  S INC=+$P(INP,U,3)
  1.  S VAL=$P(INP,U,4)
  1.  S RET=$$ITEMROOT(SFN,CAT,.GBL)
  1.  Q:RET
  1.  I ITM="" D
  1.  .F  S ITM=$O(@GBL@("B",ITM)) Q:'$L(ITM)  D SF1 Q:RET
  1.  E  D SF1
  1.  S:'RET RET=$$UPDATE^BGOUTL(.FDA)
  1.  Q
  1. SF1 ;Set up frequence
  1.  I SFN=90362.342 S DA=ITM
  1.  E  S DA=$O(@GBL@("B",ITM,0))
  1.  I 'DA S RET=$$ERR^BGOUTL(1035) Q
  1.  I $L(VAL) S CNT=+VAL
  1.  E  S CNT=$P(@GBL@(DA,0),U,3)+INC
  1.  S FDA(SFN,DA_","_CAT_",",.03)=$S(CNT>0:CNT,1:0)
  1.  Q
  1.  ; Return global root and item subfile # for a file
  1.  ;  FNUM = Preference file #
  1.  ; .GBL  = Returned global root
  1.  ; .SFN  = Returned item subfile #
  1.  ;  Return value is null if success, or -1^error text
  1. GBLROOT(FNUM,GBL,SFN) ;
  1.  N FIELD
  1.  S GBL=$$ROOT^DILFD(FNUM,,1)
  1.  Q:GBL="" $$ERR^BGOUTL(1036)
  1.  S FIELD=$S(FNUM=90362.34:2,1:1)
  1.  D FIELD^DID(FNUM,FIELD,,"SPECIFIER","SFN")
  1.  S SFN=+$G(SFN("SPECIFIER"))
  1.  K SFN("SPECIFIER")
  1.  Q:'SFN $$ERR^BGOUTL(1037)
  1.  Q ""
  1.  ; Return global root for item subfile
  1.  ;  SFN = Item subfile #
  1.  ;  CAT = Category IEN
  1.  ; .GBL = Returned global root
  1.  ;  OPN = Return open root (default=closed)
  1.  ;  Return value is null if success, or -1^error text
  1. ITEMROOT(SFN,CAT,GBL,OPN) ;
  1.  S GBL=$$ROOT^DILFD(SFN,","_CAT_",",'$G(OPN))
  1.  Q:GBL="" $$ERR^BGOUTL(1036)
  1.  Q ""
  1.  ; Clone a category
  1.  ;  INP = Source Category IEN ^ Target Category IEN
  1.  ;  FNUM = Preference file #
  1. CLONE(RET,INP,FNUM) ;EP
  1.  N FROM,TO,ITM,SFN,GBL
  1.  K RET
  1.  S RET=$$GBLROOT(FNUM,.GBL,.SFN)
  1.  Q:RET
  1.  I $G(INP)="" S RET=$$ERR^BGOUTL(1008) Q
  1.  S FROM=+INP
  1.  I 'FROM S RET=$$ERR^BGOUTL(1038) Q
  1.  I '$D(@GBL@(FROM,0)) S RET=$$ERR^BGOUTL(1039) Q
  1.  S TO=$P(INP,U,2)
  1.  I 'TO S RET=$$ERR^BGOUTL(1040) Q
  1.  I '$D(@GBL@(TO,0)) S RET=$$ERR^BGOUTL(1041) Q
  1.  I FROM=TO S RET="-1^You cannot clone this item to itself" Q
  1.  S ITM=0
  1.  F  S ITM=$O(@GBL@(FROM,1,ITM)) Q:'ITM  D  Q:RET
  1.  .N FDA,X
  1.  .Q:$O(@GBL@(TO,1,"B",ITM,0))
  1.  .S X=@GBL@(FROM,1,ITM,0)
  1.  .S FDA=$NA(FDA(SFN,"+1,"_TO_","))
  1.  .S @FDA@(.01)=+X
  1.  .S @FDA@(.03)=$P(X,U,3)
  1.  .S RET=$$UPDATE^BGOUTL(.FDA,"@")
  1.  Q
  1.  ; Check a visit for a specific provider or provider class
  1.  ;  VIEN = Visit IEN
  1.  ;  PRV  = Provider IEN (optional)
  1.  ;  CLS  = Provider Class IEN (optional)
  1.  ;  Returns true if visit contains a matching provider or provider class
  1. VISPRCL(VIEN,PRV,CLS) ;EP
  1.  N X,RET,PRV2
  1.  S (X,RET)=0
  1.  F  S X=$O(^AUPNVPRV("AD",VIEN,X)) Q:'X  D  Q:RET
  1.  .S PRV2=$P($G(^AUPNVPRV(X,0)),U)
  1.  .Q:'PRV2
  1.  .I PRV,PRV'=PRV2 Q
  1.  .I CLS,$P($G(^VA(200,PRV2,"PS")),U,5)'=CLS Q
  1.  .S RET=1
  1.  Q RET
  1.  ; Update a category's item entry
  1.  ;  FNUM = Preference file #
  1.  ;  CAT  = Category IEN
  1.  ;  PTR  = Item pointer
  1.  ;  CNT  = Item count (or "+n" to increment existing count) (optional)
  1.  ;  TXT  = Item display text (optional)
  1.  ;  NEW  = If true, force creation of new entry (optional, default=false)
  1.  ; .ITM  = Returned value of item IEN
  1.  ;  Return value is 0 if success, or -1^error text
  1. UPDITEM(FNUM,CAT,PTR,CNT,TXT,NEW,ITM) ;EP
  1.  N FDA,IEN,GBL,SFN,RET
  1.  S RET=$$GBLROOT(FNUM,.GBL,.SFN)
  1.  Q:RET RET
  1.  I FNUM=90362.34 S RET=$$UPDITEM^BGOSNOP2(FNUM,CAT,PTR,CNT,TXT,.NEW,.ITM) Q RET
  1.  S ITM=$S($G(NEW):0,1:$O(@GBL@(CAT,1,"B",PTR,0)))
  1.  S:$E($G(CNT))="+" CNT=$S(ITM:$P(@GBL@(CAT,1,ITM,0),U,3),1:0)+CNT
  1.  S FDA=$NA(FDA(SFN,$S(ITM:ITM,1:"+1")_","_CAT_","))
  1.  S @FDA@(.01)=PTR
  1.  S:$D(CNT) @FDA@(.03)=CNT
  1.  S:$D(TXT) @FDA@(.02)=$TR(TXT,";",",")
  1.  S RET=$$UPDATE^BGOUTL(.FDA,"@",.IEN)
  1.  I 'RET,'ITM S ITM=IEN(1)
  1.  Q RET
  1.  ; Return categories matching specified criteria
  1.  ;  INP = Category IEN [1] ^ Hospital Location IEN [2] ^ Provider IEN [3] ^ Manager IEN [4] ^ Show All [5] ^
  1.  ;        Historical Flag (CPT pref only) [6]
  1.  ;  FNUM = Preference file #
  1.  ;  Returns a list of records in the format:
  1.  ;   Category Name [1] ^ Category IEN [2] ^ Hosp Loc Name [3] ^ Hosp Loc IEN [4] ^
  1.  ;   Clinic Stop Name [5] ^ Clinic Stop IEN [6] ^ Provider Name [7] ^ Provider IEN [8] ^
  1.  ;   Owner Name [9] ^ Owner IEN [10] ^ Provider Class Name [11] ^ Provider Class IEN [12]
  1.  ;   ^ SNOMED Subfile [13]
  1. GETCATS(RET,INP,FNUM) ;EP
  1.  N CATIEN,CATNAME,PRVIEN,MGRIEN,SHOWALL,CAT,DISCIEN
  1.  N CLNIEN,HLIEN,PRVIEN,HIST,PRI,CNT,GBL,X0,X
  1.  S RET=$$TMPGBL^BGOUTL
  1.  S X=$$GBLROOT(FNUM,.GBL)
  1.  I X S @RET@(1)=X Q
  1.  S CATIEN=$P(INP,U)
  1.  S HLIEN=$P(INP,U,2)
  1.  S PRVIEN=$P(INP,U,3)
  1.  S MGRIEN=$P(INP,U,4)
  1.  S SHOWALL=$P(INP,U,5)
  1.  S HIST=$S(FNUM=90362.31:+$P(INP,U,6),1:2)
  1.  S:SHOWALL!(HIST=1) (CATIEN,HLIEN,PRVIEN,MGRIEN)=0
  1.  S (PRI,CNT)=0
  1.  I CATIEN D  Q
  1.  .D GC1
  1.  S CLNIEN=$S(HLIEN:$P($G(^SC(HLIEN,0)),U,7),1:"")
  1.  S DISCIEN=$S(PRVIEN:$P($G(^VA(200,PRVIEN,"PS")),U,5),1:"")
  1.  S CATNAME=""
  1.  F  S CATNAME=$O(@GBL@("B",CATNAME)) Q:CATNAME=""  D
  1.  .S CATIEN=$O(@GBL@("B",CATNAME,0))
  1.  .Q:'CATIEN
  1.  .S X0=$G(@GBL@(CATIEN,0))
  1.  .I HIST=1,'$P(X0,U,7) Q
  1.  .I 'HIST,$P(X0,U,7) Q
  1.  .S PRI=3
  1.  .I HLIEN,$P(X0,U,2) D  Q:PRI=-1
  1.  ..I $P(X0,U,2)'=HLIEN S PRI=-1
  1.  ..E  S PRI=1
  1.  .I CLNIEN,$P(X0,U,3) D  Q:PRI=-1
  1.  ..I $P(X0,U,3)'=CLNIEN S PRI=-1
  1.  ..E  S PRI=2
  1.  .I PRVIEN,$P(X0,U,4) D  Q:PRI=-1
  1.  ..I $P(X0,U,4)'=PRVIEN S PRI=-1
  1.  ..E  S PRI=0
  1.  .I DISCIEN,$P(X0,U,6) D  Q:PRI=-1
  1.  ..I $P(X0,U,6)'=DISCIEN S PRI=-1
  1.  ..E  S PRI=4
  1.  .I MGRIEN,'$D(@GBL@(CATIEN,2,MGRIEN)),$P(X0,U,5)'=MGRIEN Q
  1.  .D GC1
  1.  Q
  1. GC1 N X0,CAT,HL,CL,PRV,OWN,DISC,SUBSET,PIP,POV
  1.  S SUBSET=""
  1.  S X0=$G(@GBL@(CATIEN,0))
  1.  Q:'$L(X0)
  1.  Q:+$P(X0,U,10)  ;Quit if this list should be hidden
  1.  ;Q:+$P(X0,U,9)   ;Quit if its a prenatal list
  1.  S PIP=$P(X0,U,9)
  1.  S POV=$P(X0,U,11)
  1.  S CAT=$P(X0,U)_U_CATIEN
  1.  S HL=$P(X0,U,2)
  1.  S HL=$P($G(^SC(+HL,0)),U)_U_HL
  1.  S CL=$P(X0,U,3)
  1.  S CL=$P($G(^DIC(40.7,+CL,0)),U)_U_CL
  1.  S PRV=$P(X0,U,4)
  1.  S PRV=$P($G(^VA(200,+PRV,0)),U)_U_PRV
  1.  S OWN=$P(X0,U,5)
  1.  S OWN=$P($G(^VA(200,+OWN,0)),U)_U_OWN
  1.  S DISC=$P(X0,U,6)
  1.  S DISC=$P($G(^DIC(7,+DISC,0)),U)_U_DISC
  1.  I FNUM=90362.34 S SUBSET=$P(X0,U,8)
  1.  S CNT=CNT+1
  1.  S @RET@(PRI*1000000+CNT)=CAT_U_HL_U_CL_U_PRV_U_OWN_U_DISC_U_SUBSET_U_PIP_U_POV
  1.  Q
  1.  ; Return list of managers associated with a specified category
  1.  ;  CAT  = Category IEN
  1.  ;  FNUM = Preference file IEN
  1.  ;  Returns a list of records in the format:
  1.  ;    Provider Name ^ Provider IEN
  1. GETMGRS(RET,CAT,FNUM) ;EP
  1.  N PRV,CNT,GBL,X
  1.  K RET
  1.  S X=$$GBLROOT(FNUM,.GBL)
  1.  I X S RET(1)=X Q
  1.  I 'CAT S RET(1)=$$ERR^BGOUTL(1018) Q
  1.  I '$D(@GBL@(CAT,0)) S RET(1)=$$ERR^BGOUTL(1019) Q
  1.  S (CNT,PRV)=0
  1.  F  S PRV=$O(@GBL@(CAT,2,PRV)) Q:'PRV  D
  1.  .Q:'$D(@GBL@(CAT,2,PRV,0))
  1.  .Q:'$D(^VA(200,PRV,0))
  1.  .S CNT=CNT+1,RET(CNT)=$P(^VA(200,PRV,0),U)_U_PRV
  1.  Q
  1.  ; Set category fields
  1.  ;  INP  = Name [1] ^ Hosp Loc [2] ^ Clinic [3] ^ Provider [4] ^ User [5] ^ Category IEN [6] ^ Delete [7] ^ Discipline [8]
  1.  ;         ^ Subset [10] ^ PIP [11] ^ Hide [12] ^ Use as POV [13]
  1.  ;  FNUM = Preference file IEN
  1.  ;Patch 13 add fields for additions to SNOMED file
  1. SETCAT(RET,INP,FNUM) ;EP
  1.  N NAME,HLOC,CLN,PRV,USR,IEN,DEL,DDG,DIC,DA,DIE,DR,Y,X,DISC,GBL,DESC,SUBSET,PIP,HIDE,POV
  1.  K RET
  1.  S RET=$$GBLROOT(FNUM,.GBL)
  1.  Q:RET
  1.  S NAME=$P(INP,U)
  1.  S HLOC=$P(INP,U,2)
  1.  S CLN=$P(INP,U,3)
  1.  S PRV=$P(INP,U,4)
  1.  S USR=$P(INP,U,5)
  1.  S IEN=$P(INP,U,6)
  1.  S DEL=$P(INP,U,7)
  1.  S DISC=$P(INP,U,8)
  1.  I FNUM=90362.34 D
  1.  .S SUBSET=$P(INP,U,10)
  1.  .S PIP=$P(INP,U,11)
  1.  .S HIDE=$P(INP,U,12)
  1.  .S POV=$P(INP,U,13)
  1.  I DEL D  Q
  1.  .S RET=$$DELETE^BGOUTL(FNUM,IEN)
  1.  I NAME="" S RET=$$ERR^BGOUTL(1007) Q
  1.  I IEN,USR'=DUZ S RET=$$ERR^BGOUTL(1042) Q
  1.  I 'IEN D  Q:RET
  1.  .S IEN=$O(@GBL@("B",NAME,0))
  1.  .I IEN,USR'=DUZ S RET=$$ERR^BGOUTL(1043)
  1.  S FDA=$NA(FDA(FNUM,$S(IEN:IEN_",",1:"+1,")))
  1.  S @FDA@(.01)=NAME
  1.  S @FDA@(.02)=HLOC
  1.  S @FDA@(.03)=CLN
  1.  S @FDA@(.04)=PRV
  1.  I USR="" S USR=DUZ
  1.  S @FDA@(.05)=USR
  1.  S @FDA@(.06)=DISC
  1.  I FNUM=90362.34 D
  1.  .S @FDA@(.08)=SUBSET
  1.  .S @FDA@(.09)=PIP
  1.  .S @FDA@(1)=HIDE
  1.  .S @FDA@(1.1)=POV
  1.  S RET=$$UPDATE^BGOUTL(.FDA,"@",.X)
  1.  I 'RET,'IEN S IEN=X(1)
  1.  S:'RET RET=IEN
  1.  Q
  1.  ; Set field values for an item entry
  1.  ;  INP =  Category IEN [1] ^ Item Pointer [2] ^ Display Text [3] ^ Delete [4] ^ Item Code [5] ^ Frequency [6] ^
  1.  ;         Allow Dups [7] ^ Item IEN [8]
  1.  ;  FNUM = Preference file #
  1. SETITEM(RET,INP,FNUM) ;EP
  1.  N CAT,PTR,TXT,DEL,IEN,CODE,FREQ,DUP,ITEM,FDA,GBL
  1.  S CAT=+INP
  1.  I 'CAT S RET=$$ERR^BGOUTL(1018) Q
  1.  S PTR=$P(INP,U,2)
  1.  S TXT=$P(INP,U,3)
  1.  S DEL=$P(INP,U,4)
  1.  S CODE=$P(INP,U,5)
  1.  S FREQ=+$P(INP,U,6)
  1.  S DUP=+$P(INP,U,7)
  1.  S ITEM=$P(INP,U,8)
  1.  I DEL D
  1.  .N DA,SFN
  1.  .S RET=$$GBLROOT(FNUM,,.SFN)
  1.  .S:'RET RET=$$ITEMROOT(SFN,CAT,.GBL,1)
  1.  .Q:RET
  1.  .S DA(1)=CAT,DA=ITEM
  1.  .S RET=$$DELETE^BGOUTL(GBL,.DA)
  1.  E  D
  1.  .S RET=$$GBLROOT(FNUM,.GBL)
  1.  .D:RET'<0 @("VALIDATE"_GBL_"(.RET,.PTR,CODE)")
  1.  .S:RET'<0 RET=$$UPDITEM(FNUM,CAT,PTR,FREQ,TXT,DUP,.IEN)
  1.  .S:RET'<0 RET=IEN
  1.  Q
  1.  ; Initialize a query
  1. QRYINIT(FNUM,CAT) ;EP
  1.  L +^XTMP("BGO QUERY",FNUM,CAT):0
  1.  Q:'$T $$ERR^BGOUTL(1044)
  1.  K ^XTMP("BGO QUERY",FNUM,CAT) S ^(CAT)=0
  1.  Q ""
  1.  ; Add output to a query
  1. QRYADD(FNUM,CAT,VAL,TXT) ;EP
  1.  S:VAL ^(CAT)=$G(^XTMP("BGO QUERY",FNUM,CAT))+1,^(VAL)=$G(^(CAT,VAL))+1,^(VAL,0)=$G(TXT)
  1.  Q
  1.  ; Finish a query
  1. QRYDONE(FNUM,CAT) ;EP
  1.  N VAL,CNT,TXT,RET
  1.  S VAL=0,RET=""
  1.  F  S VAL=$O(^XTMP("BGO QUERY",FNUM,CAT,VAL)) Q:'VAL  S CNT=^(VAL),TXT=$G(^(VAL,0)) D  Q:RET
  1.  .K:'$L(TXT) TXT
  1.  .S RET=$$UPDITEM^BGOPFUTL(FNUM,CAT,VAL,"+"_CNT,.TXT)
  1.  S CNT=^XTMP("BGO QUERY",FNUM,CAT) K ^(CAT)
  1.  L -^XTMP("BGO QUERY",FNUM,CAT)
  1.  Q CNT