BGOUTL.m

BGOUTL ; IHS/BAO/TMD - Utilities ;04-Feb-2015 08:58;DU

 ;;1.1;BGO COMPONENTS;**1,3,4,5,6,13,14**;Mar 20, 2007

 ; Compute patient's age

 ;  DFN = Patient IEN

 ;  DAT = Reference date (defaults to today)

PTAGE(DFN,DAT) ;EP

 N DOB

 S DOB=+$P($G(^DPT(+DFN,0)),U,3)

 S:'$G(DAT) DAT=DT

 Q $S(DAT:$$FMDIFF^XLFDT(DT,DOB)/365.25\1,1:"")

 ; Convert a string to mixed case

MCASE(X) ;EP

 N Y

 S X=$$LOW^XLFSTR(X),Y=1

 F  D  S Y=$F(X," ",Y) Q:'Y

 .S $E(X,Y)=$$UP^XLFSTR($E(X,Y))

 Q X

 ; Check if user has specified security key

APSEC(RET,KEY) ;EP

 S RET=$D(^XUSEC(KEY,DUZ))

 Q

 ; Check security keys and parameters

 ;   INP = <key 1>|<key 2>|...|<key n>^<param 1>|<param 2>|...|<param n>^User IEN (optional)

 ;   Returned as:

 ;     <key 1>|<key 2>|...|<key n>^<param 1>|<param 2>|...|<param n>

 ;   where <key n> is boolean value for presence of key

 ;   and <param n> is of the format <user setting>~<user class name>

 ;   where <user setting> is the user setting for the parameter and

 ;   <user class name> is the user class that has a true value for

 ;   the parameter.

CHKSEC(RET,INP) ;EP

 N KEYS,PARAMS,C,X,LP,PARM,USR,CLS,UC,USER

 S RET=""

 S KEYS=$P(INP,U)

 S PARAMS=$P(INP,U,2)

 S USER=$P(INP,U,3)

 I USER,USER'=DUZ S RET=$$ERR(1053) Q

 F C=1:1 S X=$P(KEYS,"|",C) Q:X=""  S $P(KEYS,"|",C)=$$HASKEY^BEHOUSCX(X)

 F C=1:1 S PARM=$P(PARAMS,"|",C) Q:PARM=""  D

 .S USR=$$GET^XPAR("USR.`"_DUZ,PARM)

 .S CLS=""

 .S LP=0

 .F  S LP=$O(^USR(8930.3,"B",DUZ,LP)) Q:'LP  D  Q:CLS'=""

 ..S UC=$P($G(^USR(8930.3,LP,0)),U,2)

 ..Q:'UC

 ..S:$$GET^XPAR("CLS.`"_UC,PARM) CLS=$P($G(^USR(8930,UC,0)),U)

 .S $P(PARAMS,"|",C)=+USR_"~"_CLS

 S RET=KEYS_U_PARAMS

 Q

 ; Return a parameter value

CKPARM(RET,PARM) ;EP

 S RET=$$GET^XPAR("ALL",PARM)

 Q

 ; Return clinic stop associated with a location

 ;  IEN = IEN in HOSPITAL LOCATION file

 ;  RET = Returned as Name^Code

GETCLN(RET,IEN) ;EP

 S RET=$P($G(^SC(+IEN,0)),U,7)

 S:$D(^DIC(40.7,+RET,0)) RET=RET_U_$P(^(0),U,1,2)

 Q

 ;

 ; RPC to retrieve visit detail report

GETRPT(RET,VIEN) ;EP

 D GETRPT^BEHOENPS(.RET,VIEN)

 Q

 ; Return a BGO parameter value

 ;  PID = Parameter identifier

 ;  RET = Parameter value

GETPARM(RET,PID) ;EP

 I $G(PID)="" S RET=$$ERR(1054)

 E  S RET=$$GET^XPAR("ALL","BGO PARAMETER",PID)

 Q

 ; Set a BGO parameter value

 ;  INP = Parameter ID ^ Parameter Value ^ Entity (optional)

SETPARM(RET,INP) ;EP

 N PID,VAL,ENT,ERR

 S PID=$P(INP,U)

 I PID="" S RET=$$ERR(1054) Q

 S VAL=$P(INP,U,2)

 I VAL="" S RET=$$ERR(1055) Q

 S ENT=$P(INP,U,3)

 S:'$L(ENT) ENT="USR"

 D PUT^XPAR(ENT,"BGO PARAMETER",PID,VAL,.RET)

 S:RET RET="-"_RET

 Q

 ; Lock/unlock a file entry

 ;  INP = File # ^ IEN ^ Unlock Flag

LOCK(RET,INP) ;EP

 N GBL,FNUM,IEN,FLG

 S FNUM=+INP

 S IEN=+$P(INP,U,2)

 S FLG=+$P(INP,U,3)

 S GBL=$$ROOT^DILFD(FNUM,,1)

 I GBL="" S RET=$$ERR(1056) Q

 I IEN'>0 S RET=$$ERR(1057) Q

 S GBL=$NA(@GBL@(IEN))

 D LOCK^CIANBRPC(.RET,GBL):FLG,LOCK^CIANBRPC(.RET,GBL,0):'FLG

 I 'RET,'FLG S RET=$$ERR(1058)

 Q

 ; Fileman Lookup utility

 ;  INP = GBL [1] ^ Lookup Value [2] ^ FROM [3] ^ DIR [4] ^ MAX [5] ^ XREF [6] ^ SCRN [7] ^ ALL [8] ^ FLDS [9]

 ;   GBL  = File global root (open or closed, without leading ^) or file #

 ;   FROM = Text from which to start search

 ;   DIR  = Search direction (defaults to 1)

 ;   MAX  = Maximum # to return (defaults to 44)

 ;   XREF = Cross ref to use (defaults to "B")

 ;   SCRN = Screening logic (e.g. => .04="TEST";.07=83)

 ;   ALL  = Return all records, maximum of 9999

 ;   FLDS = Fields to return

 ;   VDT  = Visit Date for ICD0

DICLKUP(RET,INP) ;EP

 N GBL,LKP,FROM,DIR,MAX,VDT,XREF,XREFS,SCRN,ALL,FLDS,FNUM,CNT,IMP

 S RET=$$TMPGBL

 S GBL=$P(INP,U)

 I GBL=9999999.88,$$CSVACT^BGOUTL2 S GBL=81.3

 I GBL=+GBL S GBL=$$ROOT^DILFD(GBL,,1)

 E  S GBL=$$CREF^DILF(U_GBL)

 S FNUM=$P($G(@GBL@(0)),U,2),FNUM(0)=FNUM["P",FNUM=+FNUM

 Q:'FNUM

 S LKP=$P(INP,U,2)

 S FROM=$P(INP,U,3)

 S DIR=$P(INP,U,4)

 S MAX=$P(INP,U,5)

 S XREF=$P(INP,U,6)

 S SCRN=$TR($P(INP,U,7),"~",U)

 S ALL=$P(INP,U,8)

 S FLDS=$P(INP,U,9)

 S VDT=$P(INP,U,10)

 S:FLDS="" FLDS=".01"

 I LKP'="",FROM="" S FROM=LKP

 S CNT=0,MAX=$S(ALL:9999,MAX>0:+MAX,1:100),DIR=$S(DIR'=-1:1,1:-1)

 I GBL="^ICD0" S SCRN="",FLDS=".01",XREF="D"       ;Patch 14 for old terms

 I XREF'="" D  Q

 .S XREFS=XREF

 .F  S XREF=$P(XREFS,"~"),XREFS=$P(XREFS,"~",2,999) D DL1 Q:(XREFS="")!CNT

 S XREF="B"

 I LKP="" D DL1 Q

 F  D DL1 S XREF=$O(@GBL@(XREF)) Q:($E(XREF)'="B")!CNT

 Q

 ; Check specified xref

DL1 N NEXT,IEN

 S NEXT=FROM

 I LKP'="",XREF="B" D  Q:IEN

 .S IEN=$O(@GBL@(XREF,LKP,0))

 .I IEN,$$XSCRN(IEN,SCRN) D DL2

 F  Q:CNT'<MAX  D:$L(NEXT)  Q:'$D(NEXT)  S NEXT=$O(@GBL@(XREF,NEXT),DIR) Q:'$L(NEXT)

 .I LKP'="",$E(NEXT,1,$L(LKP))'=LKP K NEXT Q

 .S IEN=0

 .F  S IEN=$O(@GBL@(XREF,NEXT,IEN)) Q:'IEN  D

 ..N S,X,Y,I,J,FLD,OPR,VAL,N,P

 ..I SCRN'="" D  Q:'X

 ...I $E(SCRN,1,2)="I " S Y=IEN X SCRN S X=$T Q

 ...F I=1:1 S S=$P(SCRN,"&",I) Q:S=""  D  Q:'X

 ....S FLD=+S,X=0

 ....Q:'FLD

 ....S OPR=""

 ....F J=1:1:3 Q:"=<>'[]"'[$E(S,$L(FLD)+J)  S OPR=OPR_$E(S,$L(FLD)+J)

 ....Q:OPR=""

 ....S VAL=$P(S,OPR,2,999)

 ....S N=$P($G(^DD(FNUM,FLD,0)),U,4),P=$P(N,";",2),N=$P(N,";")

 ....Q:N=""!(P="")

 ....X "S X=$P($G(@GBL@(IEN,N)),U,P)"_OPR_"VAL"

 ..D DL2

 Q

 ; Add to output list

DL2 N VAL,TGT,FLD,IENS,I,X,ICDNAME,XVAL

 S IENS=IEN_","

 S VAL=""

 D GETS^DIQ(FNUM,IENS,FLDS,"I","TGT")

 I GBL="^ICD0" D

 .I $$AICD^BGOUTL2 D

 ..S XVAL=$$ICDOP^ICDEX(IEN,"","","I")

 ..S IMP=$$IMP^ICDEX("10P",VDT)

 ..I IMP<VDT D

 ...I $P(XVAL,U,15)=31&($P(XVAL,U,10)=1) S VAL=IEN

 ..E  I $P(XVAL,U,15)=2&($P(XVAL,U,10)=1) S VAL=IEN

 .E  D

 ..S XVAL=$$ICDOP^ICDCODE(IEN,"","","I")

 ..I $P(XVAL,U,15)=2&($P(XVAL,U,10)=1) S VAL=IEN

 E  S VAL=IEN_U_NEXT

 F I=1:1 S FLD=$P(FLDS,";",I) Q:'$L(FLD)  D

 .S X=$G(TGT(FNUM,IENS,FLD,"I"))

 .I FNUM(0),FLD=.01 S X=$$EXTERNAL^DILFD(FNUM,FLD,,X)

 .I VAL'="" D

 ..I GBL="^ICD0" S VAL=VAL_U_X_U_$P(XVAL,U,5)

 ..E  S VAL=VAL_U_X

 I VAL'="" S CNT=CNT+1,@RET@(CNT)=VAL

 Q

 ; Fileman Lookup utility (uses FIND^DIC)

 ;  INP = GBL [1] ^ Lookup Value [2] ^ FROM [3] ^ DIR [4] ^ MAX [5] ^ XREF [6] ^ SCRN [7] ^ ALL [8] ^ FLDS [9]

 ;   GBL  = File global root (open or closed, without leading ^) or file #

 ;   FROM = Text from which to start search

 ;   DIR  = Search direction (not supported)

 ;   MAX  = Maximum # to return (defaults to 44)

 ;   XREF = Cross ref to use (defaults to "B")

 ;   SCRN = Screening logic (e.g. => .04="TEST";.07=83)

 ;   ALL  = Return all records, maximum of 9999

 ;   FLDS = Fields to return

DICLKUP2(RET,INP) ;EP

 N GBL,LKP,FROM,DIR,MAX,XREF,XREFS,SCRN,ALL,FLDS,FNUM,LP,X

 S RET=$$TMPGBL

 S GBL=$P(INP,U)

 I GBL=+GBL S GBL=$$ROOT^DILFD(GBL,,1)

 E  S GBL=$$CREF^DILF(U_GBL)

 S FNUM=$P($G(@GBL@(0)),U,2),FNUM(0)=FNUM["P",FNUM=+FNUM

 Q:'FNUM

 S LKP=$P(INP,U,2)

 S FROM=$P(INP,U,3)

 S DIR=$P(INP,U,4)                                                     ; ignored

 S MAX=$P(INP,U,5)

 S XREF=$TR($P(INP,U,6),"~",U)

 S SCRN=$TR($P(INP,U,7),"~",U)

 S ALL=$P(INP,U,8)

 S FLDS=$P(INP,U,9)

 S:FLDS="" FLDS=".01"

 F LP=1:1:$L(FLDS,";") D

 .S X=$P(FLDS,";",LP)

 .S $P(FLDS,";",LP)=X_$S(X=.01&FNUM(0):"E",1:"I")

 I LKP'="",FROM="" S FROM=LKP

 S MAX=$S(ALL:9999,MAX>0:+MAX,1:100),DIR=$S(DIR'=-1:1,1:-1)

 D FIND^DIC(FNUM,,"@;IX;"_FLDS,"BP",LKP,MAX,XREF,SCRN,,RET)

 K @RET@("DILIST",0)

 Q

 ; Returns true if active hospital location

 ;  LOC = IEN of hospital location

 ;  DAT = optional date to check (defaults to today)

ACTHLOC(LOC,DAT) ;

 Q $$ACTLOC^BEHOENCX(LOC,.DAT)

 ; Returns true if user is a provider and is active

ACTPRV(IEN,DAT) ;

 Q $$ACTIVE^BEHOUSCX(IEN,.DAT)&$$HASKEY^BEHOUSCX("PROVIDER")

 ; Returns true if routine exists

 ;  X = Routine or routine^tag

 ; .Y error message returned if not found

TEST(X,Y) ;EP

 S:X[U X=$P(X,U,2)

 Q:'$L(X)!(X'?.1"%"1.AN) 0

 X ^%ZOSF("TEST")

 Q:$T 1

 S Y=$$ERR(1059,X)

 Q 0

 ; Get CPT modifiers for a CPT code

CPTMODS(RET,INP) ;EP

 Q:'$$TEST("CPTMODS^ORWPCE",.RET)

 D CPTMODS^ORWPCE(.RET,INP)

 Q

 ; Perform lookup in lexicon

 ;  INP = Term ^ Type (ICD/CHP)

LEXLKUP(RET,INP) ;EP

 N TERM,TYPE,VDT

 Q:'$$TEST("LEX^ORWPCE",.RET)

 S TERM=$P(INP,U)

 Q:TERM=""

 S TYPE=$P(INP,U,2)

 Q:TYPE=""

 S VDT=$P(INP,U,3)

 D LEX^ORWPCE(.RET,TERM,TYPE,VDT)

 Q

 ; Lexicon ICD lookup

 ;  TERM = Term to lookup

ICDLEX(RET,TERM) ;EP

 S $P(TERM,U,2)="ICD"

 D LEXLKUP(.RET,TERM)

 Q

 ; Return IEN of ICD code

ICDIEN(RET,ICD) ;EP

 S RET=$S($L(ICD):$O(^ICD9("AB",ICD,"")),1:"")

 Q

 ; Get ICD IEN from lexicon IEN

ICDLEXCD(RET,LEX) ;EP

 Q:'$$TEST("LEXCODE^ORWPCE",.RET)

 D LEXCODE^ORWPCE(.RET,LEX,"ICD"),ICDIEN(.RET,RET)

 Q

 ; Get CPT IEN from lexicon IEN

CPTLEXCD(RET,LEX) ;EP

 Q:'$$TEST("LEXCODE^ORWPCE",.RET)

 D LEXCODE^ORWPCE(.RET,LEX,"CHP")

 S:$L(RET) RET=$O(^ICPT("B",RET,""))

 Q

 ; Returns the clinic stop associated with a visit

 ;  VIEN = Visit IEN

VCLN(RET,VIEN) ;EP

 I '$G(VIEN) S RET=$$ERR(1002)

 E  I '$D(^AUPNVSIT(VIEN,0)) S RET=$$ERR(1003)

 E  S RET=$P(^AUPNVSIT(VIEN,0),U,8),RET=$P($G(^DIC(40.7,+RET,0)),U,2)

 Q

 ; Returns 1 if a visit exists for current day

 ;  DFN = Patient IEN

FIRVIS(RET,DFN) ;EP

 I '$G(DFN) S RET=$$ERR(1050)

 E  I '$D(^DPT(DFN,0)) S RET=$$ERR(1001)

 E  I $O(^AUPNVSIT("AA",DFN,9999999-DT+.2359)) S RET=0

 E  S RET=1

 Q

 ; Delete a V file entry

 ;  INP = V File # ^ V File IEN

VFDEL(RET,INP) ;EP

 D VFDEL^BGOUTL2(.RET,+INP,+$P(INP,U,2))

 Q

 ; Fetch a record from a file

GETREC(FNUM,IEN,FLDS) ;EP

 N RET,FLD,IENS,VAL,I,X,Y

 S IENS=IEN_",",RET=IEN

 D GETS^DIQ(FNUM,IENS,FLDS,"IE","VAL")

 F I=1:1:$L(FLDS,";") D

 .S FLD=$P(FLDS,";",I)

 .S X=$G(VAL(FNUM,IENS,FLD,"E")),Y=$G(VAL(FNUM,IENS,FLD,"I"))

 .S:X'=Y X=X_"|"_Y

 .S $P(RET,U,I+1)=X

 Q RET

 ; Add/edit a file entry

UPDATE(FDA,FLG,IEN) ;EP

 N ERR,DFN,X

 I $G(FLG)["@" S FLG=$TR(FLG,"@")

 E  D

 .S X="FDA"

 .F  S X=$Q(@X) Q:'$L(X)  K:'$L(@X) @X

 Q:$D(FDA)'>1 ""

 D UPDATE^DIE(.FLG,"FDA","IEN","ERR")

 K FDA

 Q $S($G(ERR("DIERR",1)):-ERR("DIERR",1)_U_ERR("DIERR",1,"TEXT",1),1:"")

 ; Delete an entry from a file

DELETE(DIK,DA) ;EP

 N CREF,X,Y

 S:DIK=+DIK DIK=$$ROOT^DILFD(DIK)

 S CREF=$$CREF^DILF(DIK)

 D ^DIK

 Q $S($D(@CREF@(DA)):$$ERR(1060,$P($G(@CREF@(0),"UNKNOWN"),U)),1:"")

 ; Check and validate visit

CHKVISIT(VIEN,DFN,CAT) ;EP

 N RET,X0

 S RET=$$ISLOCKED^BEHOENCX(VIEN)

 Q:RET $S(RET<0:$$ERR(1003),1:$$ERR(1061))

 S X0=$G(^AUPNVSIT(VIEN,0))

 I $G(DFN),$P(X0,U,5)'=DFN S RET=$$ERR(1062)

 E  I $P(X0,U,11) S RET=$$ERR(1063)

 E  I $L($G(CAT)),CAT'[$P(X0,U,7) S RET=$$ERR(1064,$$EXTERNAL^DILFD(9000010,.07,,$P(X0,U,7)))

 Q RET

 ; Get primary provider for a visit

 ;  VIEN = Visit IEN

 ;  Returns Provider IEN ^ Provider Name ^ V Provider IEN

PRIPRV(VIEN) ;EP

 N X,RET

 Q:'VIEN $$ERR(1002)

 S X=0,RET=$$ERR(1065)

 F  S X=$O(^AUPNVPRV("AD",VIEN,X)) Q:'X  D  Q:RET>0

 .S Y=$G(^AUPNVPRV(X,0))

 .S:$P(Y,U,4)="P" RET=$P(Y,U)_U_$P($G(^VA(200,+Y,0)),U)_U_X

 Q RET

 ; Create an historical visit

MAKEHIST(DFN,EVNTDT,LOC,VIEN) ;EP

 S EVNTDT=$$CVTDATE(EVNTDT)

 S:EVNTDT#100\1=0 EVNTDT=EVNTDT+1

 Q:EVNTDT\1>DT $$ERR(1066)

 I $G(VIEN) D  Q:VIEN VIEN

 .N X,V,L

 .S X=$G(^AUPNVSIT(VIEN,0)),L=$G(^(21)),V=VIEN,VIEN=0

 .Q:DFN'=$P(X,U,5)

 .Q:$P(X,U,7)'="E"

 .I X\1'=EVNTDT,+X'=EVNTDT Q

 .I LOC=+LOC Q:$P(X,U,6)'=LOC

 .E  I $L(LOC),$P(L,U)'=LOC,$$GET1^DIQ(4,$P(X,U,6),.01)'=LOC Q

 .S VIEN=V

 Q $$FNDVIS^BEHOENCX(DFN,EVNTDT,"E","",-1,,LOC)

 ; Convert date to internal format

CVTDATE(X) ;EP

 Q:"@"[X X

 S:X?1.E1" "1.2N1":"2N.E X=$P(X," ")_"@"_$P(X," ",2,99)

 D DT^DILF("PT",X,.X)

 Q $S(X>0:X,1:"")

 ; Convert date to MM/DD/YYYY format

 ; If TM is nonzero, include time portion

FMTDATE(X,TM) ;EP

 Q:'X ""

 N M,D,V

 S V=$TR($$FMTE^XLFDT(X,$S($G(TM):"5ZM",1:"5ZD")),"@"," ")

 Q V

 ;S M=$E(X,4,5),D=$E(X,6,7),V=$E(X,1,3)+1700

 ;S:M&D V=D_"/"_V

 ;S:M V=M_"/"_V

 ;I $G(TM) D

 ;.S X=X#1

 ;.Q:'X

 ;.S X=$TR($J(X*10000\1,4),0)

 ;.S V=V_" "_$E(X,1,2)_":"_$E(X,3,4)

 ;Q V

 ; Convert a string to WP format

TOWP(X) ;EP

 N I,L,L2,Y,Z

 S Y=@X

 K @X

 S:Y="@" Y=""

 F I=1:1 Q:'$L(Y)  D

 .S L=$F(Y,$C(13))

 .I 'L!(L>242) D

 ..S L=$S($L(Y)'>240:999,1:0)

 ..F  S L2=$F(Y," ",L) Q:'L2!(L2>242)  S L=L2

 .I 'L S Z=$E(Y,1,240),Y=$E(Y,241,99999)

 .E  S Z=$E(Y,1,L-2),Y=$E(Y,L,99999)

 .S @X@(I,0)=$TR(Z,$C(13,10))

 Q $S($D(@X):X,1:"")

 ; Convert a value to internal format

TOINTRNL(FNUM,FLD,VAL) ;EP

 N RET

 D CHK^DIE(FNUM,FLD,,VAL,.RET)

 Q $S(U[$G(RET):"",1:RET)

 ; Return an error code/error dialog

ERR(CODE,PARAMS) ;EP

 Q -CODE_U_$$EZBLD^DIALOG(CODE+903620000,.PARAMS)

 ; Return a temporary global reference

TMPGBL(X) ;EP

 K ^TMP("BGO"_$G(X),$J) Q $NA(^($J))

 ; Returns status of screen application

 ;  0=failed  1=passed

XSCRN(IEN,SCRN) ;EP

 N S,X,Y,I,J,FLD,OPR,VAL,N,P

 S X=1  ; Default to passed

 I SCRN'="" D

 .I $E(SCRN,1,2)="I " D

 ..S Y=IEN X SCRN S X=$T

 .E  D

 ..F I=1:1 S S=$P(SCRN,"&",I) Q:S=""  D  Q:'X

 ...S FLD=+S,X=0

 ...Q:'FLD

 ...S OPR=""

 ...F J=1:1:3 Q:"=<>'[]"'[$E(S,$L(FLD)+J)  S OPR=OPR_$E(S,$L(FLD)+J)

 ...Q:OPR=""

 ...S VAL=$P(S,OPR,2,999)

 ...S N=$P($G(^DD(FNUM,FLD,0)),U,4),P=$P(N,";",2),N=$P(N,";")

 ...Q:N=""!(P="")

 ...X "S X=$P($G(@GBL@(IEN,N)),U,P)"_OPR_"VAL"

 Q X

BGOUTL    ; IHS/BAO/TMD - Utilities ;04-Feb-2015 08:58;DU

 +1       ;;1.1;BGO COMPONENTS;**1,3,4,5,6,13,14**;Mar 20, 2007

 +2       ; Compute patient's age

 +3       ;  DFN = Patient IEN

 +4       ;  DAT = Reference date (defaults to today)

PTAGE(DFN,DAT) ;EP

 +1        NEW DOB

 +2        SET DOB=+$PIECE($GET(^DPT(+DFN,0)),U,3)

 +3        IF '$GET(DAT)

               SET DAT=DT

 +4        QUIT $SELECT(DAT:$$FMDIFF^XLFDT(DT,DOB)/365.25\1,1:"")

 +5       ; Convert a string to mixed case

MCASE(X)  ;EP

 +1        NEW Y

 +2        SET X=$$LOW^XLFSTR(X)

           SET Y=1

 +3        FOR 

               Begin DoDot:1

 +4                SET $EXTRACT(X,Y)=$$UP^XLFSTR($EXTRACT(X,Y))

               End DoDot:1

               SET Y=$FIND(X," ",Y)

               IF 'Y

                   QUIT 

 +5        QUIT X

 +6       ; Check if user has specified security key

APSEC(RET,KEY) ;EP

 +1        SET RET=$DATA(^XUSEC(KEY,DUZ))

 +2        QUIT 

 +3       ; Check security keys and parameters

 +4       ;   INP = <key 1>|<key 2>|...|<key n>^<param 1>|<param 2>|...|<param n>^User IEN (optional)

 +5       ;   Returned as:

 +6       ;     <key 1>|<key 2>|...|<key n>^<param 1>|<param 2>|...|<param n>

 +7       ;   where <key n> is boolean value for presence of key

 +8       ;   and <param n> is of the format <user setting>~<user class name>

 +9       ;   where <user setting> is the user setting for the parameter and

 +10      ;   <user class name> is the user class that has a true value for

 +11      ;   the parameter.

CHKSEC(RET,INP) ;EP

 +1        NEW KEYS,PARAMS,C,X,LP,PARM,USR,CLS,UC,USER

 +2        SET RET=""

 +3        SET KEYS=$PIECE(INP,U)

 +4        SET PARAMS=$PIECE(INP,U,2)

 +5        SET USER=$PIECE(INP,U,3)

 +6        IF USER

               IF USER'=DUZ

                   SET RET=$$ERR(1053)

                   QUIT 

 +7        FOR C=1:1

               SET X=$PIECE(KEYS,"|",C)

               IF X=""

                   QUIT 

               SET $PIECE(KEYS,"|",C)=$$HASKEY^BEHOUSCX(X)

 +8        FOR C=1:1

               SET PARM=$PIECE(PARAMS,"|",C)

               IF PARM=""

                   QUIT 

               Begin DoDot:1

 +9                SET USR=$$GET^XPAR("USR.`"_DUZ,PARM)

 +10               SET CLS=""

 +11               SET LP=0

 +12               FOR 

                       SET LP=$ORDER(^USR(8930.3,"B",DUZ,LP))

                       IF 'LP

                           QUIT 

                       Begin DoDot:2

 +13                       SET UC=$PIECE($GET(^USR(8930.3,LP,0)),U,2)

 +14                       IF 'UC

                               QUIT 

 +15                       IF $$GET^XPAR("CLS.`"_UC,PARM)

                               SET CLS=$PIECE($GET(^USR(8930,UC,0)),U)

                       End DoDot:2

                       IF CLS'=""

                           QUIT 

 +16               SET $PIECE(PARAMS,"|",C)=+USR_"~"_CLS

               End DoDot:1

 +17       SET RET=KEYS_U_PARAMS

 +18       QUIT 

 +19      ; Return a parameter value

CKPARM(RET,PARM) ;EP

 +1        SET RET=$$GET^XPAR("ALL",PARM)

 +2        QUIT 

 +3       ; Return clinic stop associated with a location

 +4       ;  IEN = IEN in HOSPITAL LOCATION file

 +5       ;  RET = Returned as Name^Code

GETCLN(RET,IEN) ;EP

 +1        SET RET=$PIECE($GET(^SC(+IEN,0)),U,7)

 +2        IF $DATA(^DIC(40.7,+RET,0))

               SET RET=RET_U_$PIECE(^(0),U,1,2)

 +3        QUIT 

 +4       ;

 +5       ; RPC to retrieve visit detail report

GETRPT(RET,VIEN) ;EP

 +1        DO GETRPT^BEHOENPS(.RET,VIEN)

 +2        QUIT 

 +3       ; Return a BGO parameter value

 +4       ;  PID = Parameter identifier

 +5       ;  RET = Parameter value

GETPARM(RET,PID) ;EP

 +1        IF $GET(PID)=""

               SET RET=$$ERR(1054)

 +2       IF '$TEST

               SET RET=$$GET^XPAR("ALL","BGO PARAMETER",PID)

 +3        QUIT 

 +4       ; Set a BGO parameter value

 +5       ;  INP = Parameter ID ^ Parameter Value ^ Entity (optional)

SETPARM(RET,INP) ;EP

 +1        NEW PID,VAL,ENT,ERR

 +2        SET PID=$PIECE(INP,U)

 +3        IF PID=""

               SET RET=$$ERR(1054)

               QUIT 

 +4        SET VAL=$PIECE(INP,U,2)

 +5        IF VAL=""

               SET RET=$$ERR(1055)

               QUIT 

 +6        SET ENT=$PIECE(INP,U,3)

 +7        IF '$LENGTH(ENT)

               SET ENT="USR"

 +8        DO PUT^XPAR(ENT,"BGO PARAMETER",PID,VAL,.RET)

 +9        IF RET

               SET RET="-"_RET

 +10       QUIT 

 +11      ; Lock/unlock a file entry

 +12      ;  INP = File # ^ IEN ^ Unlock Flag

LOCK(RET,INP) ;EP

 +1        NEW GBL,FNUM,IEN,FLG

 +2        SET FNUM=+INP

 +3        SET IEN=+$PIECE(INP,U,2)

 +4        SET FLG=+$PIECE(INP,U,3)

 +5        SET GBL=$$ROOT^DILFD(FNUM,,1)

 +6        IF GBL=""

               SET RET=$$ERR(1056)

               QUIT 

 +7        IF IEN'>0

               SET RET=$$ERR(1057)

               QUIT 

 +8        SET GBL=$NAME(@GBL@(IEN))

 +9        IF FLG

               DO LOCK^CIANBRPC(.RET,GBL)

           IF 'FLG

               DO LOCK^CIANBRPC(.RET,GBL,0)

 +10       IF 'RET

               IF 'FLG

                   SET RET=$$ERR(1058)

 +11       QUIT 

 +12      ; Fileman Lookup utility

 +13      ;  INP = GBL [1] ^ Lookup Value [2] ^ FROM [3] ^ DIR [4] ^ MAX [5] ^ XREF [6] ^ SCRN [7] ^ ALL [8] ^ FLDS [9]

 +14      ;   GBL  = File global root (open or closed, without leading ^) or file #

 +15      ;   FROM = Text from which to start search

 +16      ;   DIR  = Search direction (defaults to 1)

 +17      ;   MAX  = Maximum # to return (defaults to 44)

 +18      ;   XREF = Cross ref to use (defaults to "B")

 +19      ;   SCRN = Screening logic (e.g. => .04="TEST";.07=83)

 +20      ;   ALL  = Return all records, maximum of 9999

 +21      ;   FLDS = Fields to return

 +22      ;   VDT  = Visit Date for ICD0

DICLKUP(RET,INP) ;EP

 +1        NEW GBL,LKP,FROM,DIR,MAX,VDT,XREF,XREFS,SCRN,ALL,FLDS,FNUM,CNT,IMP

 +2        SET RET=$$TMPGBL

 +3        SET GBL=$PIECE(INP,U)

 +4        IF GBL=9999999.88

               IF $$CSVACT^BGOUTL2

                   SET GBL=81.3

 +5        IF GBL=+GBL

               SET GBL=$$ROOT^DILFD(GBL,,1)

 +6       IF '$TEST

               SET GBL=$$CREF^DILF(U_GBL)

 +7        SET FNUM=$PIECE($GET(@GBL@(0)),U,2)

           SET FNUM(0)=FNUM["P"

           SET FNUM=+FNUM

 +8        IF 'FNUM

               QUIT 

 +9        SET LKP=$PIECE(INP,U,2)

 +10       SET FROM=$PIECE(INP,U,3)

 +11       SET DIR=$PIECE(INP,U,4)

 +12       SET MAX=$PIECE(INP,U,5)

 +13       SET XREF=$PIECE(INP,U,6)

 +14       SET SCRN=$TRANSLATE($PIECE(INP,U,7),"~",U)