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