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)
+15 SET ALL=$PIECE(INP,U,8)
+16 SET FLDS=$PIECE(INP,U,9)
+17 SET VDT=$PIECE(INP,U,10)
+18 IF FLDS=""
SET FLDS=".01"
+19 IF LKP'=""
IF FROM=""
SET FROM=LKP
+20 SET CNT=0
SET MAX=$SELECT(ALL:9999,MAX>0:+MAX,1:100)
SET DIR=$SELECT(DIR'=-1:1,1:-1)
+21 ;Patch 14 for old terms
IF GBL="^ICD0"
SET SCRN=""
SET FLDS=".01"
SET XREF="D"
+22 IF XREF'=""
Begin DoDot:1
+23 SET XREFS=XREF
+24 FOR
SET XREF=$PIECE(XREFS,"~")
SET XREFS=$PIECE(XREFS,"~",2,999)
DO DL1
IF (XREFS="")!CNT
QUIT
End DoDot:1
QUIT
+25 SET XREF="B"
+26 IF LKP=""
DO DL1
QUIT
+27 FOR
DO DL1
SET XREF=$ORDER(@GBL@(XREF))
IF ($EXTRACT(XREF)'="B")!CNT
QUIT
+28 QUIT
+29 ; Check specified xref
DL1 NEW NEXT,IEN
+1 SET NEXT=FROM
+2 IF LKP'=""
IF XREF="B"
Begin DoDot:1
+3 SET IEN=$ORDER(@GBL@(XREF,LKP,0))
+4 IF IEN
IF $$XSCRN(IEN,SCRN)
DO DL2
End DoDot:1
IF IEN
QUIT
+5 FOR
IF CNT'<MAX
QUIT
IF $LENGTH(NEXT)
Begin DoDot:1
+6 IF LKP'=""
IF $EXTRACT(NEXT,1,$LENGTH(LKP))'=LKP
KILL NEXT
QUIT
+7 SET IEN=0
+8 FOR
SET IEN=$ORDER(@GBL@(XREF,NEXT,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+9 NEW S,X,Y,I,J,FLD,OPR,VAL,N,P
+10 IF SCRN'=""
Begin DoDot:3
+11 IF $EXTRACT(SCRN,1,2)="I "
SET Y=IEN
XECUTE SCRN
SET X=$TEST
QUIT
+12 FOR I=1:1
SET S=$PIECE(SCRN,"&",I)
IF S=""
QUIT
Begin DoDot:4
+13 SET FLD=+S
SET X=0
+14 IF 'FLD
QUIT
+15 SET OPR=""
+16 FOR J=1:1:3
IF "=<>'[]"'[$EXTRACT(S,$LENGTH(FLD)+J)
QUIT
SET OPR=OPR_$EXTRACT(S,$LENGTH(FLD)+J)
+17 IF OPR=""
QUIT
+18 SET VAL=$PIECE(S,OPR,2,999)
+19 SET N=$PIECE($GET(^DD(FNUM,FLD,0)),U,4)
SET P=$PIECE(N,";",2)
SET N=$PIECE(N,";")
+20 IF N=""!(P="")
QUIT
+21 XECUTE "S X=$P($G(@GBL@(IEN,N)),U,P)"_OPR_"VAL"
End DoDot:4
IF 'X
QUIT
End DoDot:3
IF 'X
QUIT
+22 DO DL2
End DoDot:2
End DoDot:1
IF '$DATA(NEXT)
QUIT
SET NEXT=$ORDER(@GBL@(XREF,NEXT),DIR)
IF '$LENGTH(NEXT)
QUIT
+23 QUIT
+24 ; Add to output list
DL2 NEW VAL,TGT,FLD,IENS,I,X,ICDNAME,XVAL
+1 SET IENS=IEN_","
+2 SET VAL=""
+3 DO GETS^DIQ(FNUM,IENS,FLDS,"I","TGT")
+4 IF GBL="^ICD0"
Begin DoDot:1
+5 IF $$AICD^BGOUTL2
Begin DoDot:2
+6 SET XVAL=$$ICDOP^ICDEX(IEN,"","","I")
+7 SET IMP=$$IMP^ICDEX("10P",VDT)
+8 IF IMP<VDT
Begin DoDot:3
+9 IF $PIECE(XVAL,U,15)=31&($PIECE(XVAL,U,10)=1)
SET VAL=IEN
End DoDot:3
+10 IF '$TEST
IF $PIECE(XVAL,U,15)=2&($PIECE(XVAL,U,10)=1)
SET VAL=IEN
End DoDot:2
+11 IF '$TEST
Begin DoDot:2
+12 SET XVAL=$$ICDOP^ICDCODE(IEN,"","","I")
+13 IF $PIECE(XVAL,U,15)=2&($PIECE(XVAL,U,10)=1)
SET VAL=IEN
End DoDot:2
End DoDot:1
+14 IF '$TEST
SET VAL=IEN_U_NEXT
+15 FOR I=1:1
SET FLD=$PIECE(FLDS,";",I)
IF '$LENGTH(FLD)
QUIT
Begin DoDot:1
+16 SET X=$GET(TGT(FNUM,IENS,FLD,"I"))
+17 IF FNUM(0)
IF FLD=.01
SET X=$$EXTERNAL^DILFD(FNUM,FLD,,X)
+18 IF VAL'=""
Begin DoDot:2
+19 IF GBL="^ICD0"
SET VAL=VAL_U_X_U_$PIECE(XVAL,U,5)
+20 IF '$TEST
SET VAL=VAL_U_X
End DoDot:2
End DoDot:1
+21 IF VAL'=""
SET CNT=CNT+1
SET @RET@(CNT)=VAL
+22 QUIT
+23 ; Fileman Lookup utility (uses FIND^DIC)
+24 ; INP = GBL [1] ^ Lookup Value [2] ^ FROM [3] ^ DIR [4] ^ MAX [5] ^ XREF [6] ^ SCRN [7] ^ ALL [8] ^ FLDS [9]
+25 ; GBL = File global root (open or closed, without leading ^) or file #
+26 ; FROM = Text from which to start search
+27 ; DIR = Search direction (not supported)
+28 ; MAX = Maximum # to return (defaults to 44)
+29 ; XREF = Cross ref to use (defaults to "B")
+30 ; SCRN = Screening logic (e.g. => .04="TEST";.07=83)
+31 ; ALL = Return all records, maximum of 9999
+32 ; FLDS = Fields to return
DICLKUP2(RET,INP) ;EP
+1 NEW GBL,LKP,FROM,DIR,MAX,XREF,XREFS,SCRN,ALL,FLDS,FNUM,LP,X
+2 SET RET=$$TMPGBL
+3 SET GBL=$PIECE(INP,U)
+4 IF GBL=+GBL
SET GBL=$$ROOT^DILFD(GBL,,1)
+5 IF '$TEST
SET GBL=$$CREF^DILF(U_GBL)
+6 SET FNUM=$PIECE($GET(@GBL@(0)),U,2)
SET FNUM(0)=FNUM["P"
SET FNUM=+FNUM
+7 IF 'FNUM
QUIT
+8 SET LKP=$PIECE(INP,U,2)
+9 SET FROM=$PIECE(INP,U,3)
+10 ; ignored
SET DIR=$PIECE(INP,U,4)
+11 SET MAX=$PIECE(INP,U,5)
+12 SET XREF=$TRANSLATE($PIECE(INP,U,6),"~",U)
+13 SET SCRN=$TRANSLATE($PIECE(INP,U,7),"~",U)
+14 SET ALL=$PIECE(INP,U,8)
+15 SET FLDS=$PIECE(INP,U,9)
+16 IF FLDS=""
SET FLDS=".01"
+17 FOR LP=1:1:$LENGTH(FLDS,";")
Begin DoDot:1
+18 SET X=$PIECE(FLDS,";",LP)
+19 SET $PIECE(FLDS,";",LP)=X_$SELECT(X=.01&FNUM(0):"E",1:"I")
End DoDot:1
+20 IF LKP'=""
IF FROM=""
SET FROM=LKP
+21 SET MAX=$SELECT(ALL:9999,MAX>0:+MAX,1:100)
SET DIR=$SELECT(DIR'=-1:1,1:-1)
+22 DO FIND^DIC(FNUM,,"@;IX;"_FLDS,"BP",LKP,MAX,XREF,SCRN,,RET)
+23 KILL @RET@("DILIST",0)
+24 QUIT
+25 ; Returns true if active hospital location
+26 ; LOC = IEN of hospital location
+27 ; DAT = optional date to check (defaults to today)
ACTHLOC(LOC,DAT) ;
+1 QUIT $$ACTLOC^BEHOENCX(LOC,.DAT)
+2 ; Returns true if user is a provider and is active
ACTPRV(IEN,DAT) ;
+1 QUIT $$ACTIVE^BEHOUSCX(IEN,.DAT)&$$HASKEY^BEHOUSCX("PROVIDER")
+2 ; Returns true if routine exists
+3 ; X = Routine or routine^tag
+4 ; .Y error message returned if not found
TEST(X,Y) ;EP
+1 IF X[U
SET X=$PIECE(X,U,2)
+2 IF '$LENGTH(X)!(X'?.1"%"1.AN)
QUIT 0
+3 XECUTE ^%ZOSF("TEST")
+4 IF $TEST
QUIT 1
+5 SET Y=$$ERR(1059,X)
+6 QUIT 0
+7 ; Get CPT modifiers for a CPT code
CPTMODS(RET,INP) ;EP
+1 IF '$$TEST("CPTMODS^ORWPCE",.RET)
QUIT
+2 DO CPTMODS^ORWPCE(.RET,INP)
+3 QUIT
+4 ; Perform lookup in lexicon
+5 ; INP = Term ^ Type (ICD/CHP)
LEXLKUP(RET,INP) ;EP
+1 NEW TERM,TYPE,VDT
+2 IF '$$TEST("LEX^ORWPCE",.RET)
QUIT
+3 SET TERM=$PIECE(INP,U)
+4 IF TERM=""
QUIT
+5 SET TYPE=$PIECE(INP,U,2)
+6 IF TYPE=""
QUIT
+7 SET VDT=$PIECE(INP,U,3)
+8 DO LEX^ORWPCE(.RET,TERM,TYPE,VDT)
+9 QUIT
+10 ; Lexicon ICD lookup
+11 ; TERM = Term to lookup
ICDLEX(RET,TERM) ;EP
+1 SET $PIECE(TERM,U,2)="ICD"
+2 DO LEXLKUP(.RET,TERM)
+3 QUIT
+4 ; Return IEN of ICD code
ICDIEN(RET,ICD) ;EP
+1 SET RET=$SELECT($LENGTH(ICD):$ORDER(^ICD9("AB",ICD,"")),1:"")
+2 QUIT
+3 ; Get ICD IEN from lexicon IEN
ICDLEXCD(RET,LEX) ;EP
+1 IF '$$TEST("LEXCODE^ORWPCE",.RET)
QUIT
+2 DO LEXCODE^ORWPCE(.RET,LEX,"ICD")
DO ICDIEN(.RET,RET)
+3 QUIT
+4 ; Get CPT IEN from lexicon IEN
CPTLEXCD(RET,LEX) ;EP
+1 IF '$$TEST("LEXCODE^ORWPCE",.RET)
QUIT
+2 DO LEXCODE^ORWPCE(.RET,LEX,"CHP")
+3 IF $LENGTH(RET)
SET RET=$ORDER(^ICPT("B",RET,""))
+4 QUIT
+5 ; Returns the clinic stop associated with a visit
+6 ; VIEN = Visit IEN
VCLN(RET,VIEN) ;EP
+1 IF '$GET(VIEN)
SET RET=$$ERR(1002)
+2 IF '$TEST
IF '$DATA(^AUPNVSIT(VIEN,0))
SET RET=$$ERR(1003)
+3 IF '$TEST
SET RET=$PIECE(^AUPNVSIT(VIEN,0),U,8)
SET RET=$PIECE($GET(^DIC(40.7,+RET,0)),U,2)
+4 QUIT
+5 ; Returns 1 if a visit exists for current day
+6 ; DFN = Patient IEN
FIRVIS(RET,DFN) ;EP
+1 IF '$GET(DFN)
SET RET=$$ERR(1050)
+2 IF '$TEST
IF '$DATA(^DPT(DFN,0))
SET RET=$$ERR(1001)
+3 IF '$TEST
IF $ORDER(^AUPNVSIT("AA",DFN,9999999-DT+.2359))
SET RET=0
+4 IF '$TEST
SET RET=1
+5 QUIT
+6 ; Delete a V file entry
+7 ; INP = V File # ^ V File IEN
VFDEL(RET,INP) ;EP
+1 DO VFDEL^BGOUTL2(.RET,+INP,+$PIECE(INP,U,2))
+2 QUIT
+3 ; Fetch a record from a file
GETREC(FNUM,IEN,FLDS) ;EP
+1 NEW RET,FLD,IENS,VAL,I,X,Y
+2 SET IENS=IEN_","
SET RET=IEN
+3 DO GETS^DIQ(FNUM,IENS,FLDS,"IE","VAL")
+4 FOR I=1:1:$LENGTH(FLDS,";")
Begin DoDot:1
+5 SET FLD=$PIECE(FLDS,";",I)
+6 SET X=$GET(VAL(FNUM,IENS,FLD,"E"))
SET Y=$GET(VAL(FNUM,IENS,FLD,"I"))
+7 IF X'=Y
SET X=X_"|"_Y
+8 SET $PIECE(RET,U,I+1)=X
End DoDot:1
+9 QUIT RET
+10 ; Add/edit a file entry
UPDATE(FDA,FLG,IEN) ;EP
+1 NEW ERR,DFN,X
+2 IF $GET(FLG)["@"
SET FLG=$TRANSLATE(FLG,"@")
+3 IF '$TEST
Begin DoDot:1
+4 SET X="FDA"
+5 FOR
SET X=$QUERY(@X)
IF '$LENGTH(X)
QUIT
IF '$LENGTH(@X)
KILL @X
End DoDot:1
+6 IF $DATA(FDA)'>1
QUIT ""
+7 DO UPDATE^DIE(.FLG,"FDA","IEN","ERR")
+8 KILL FDA
+9 QUIT $SELECT($GET(ERR("DIERR",1)):-ERR("DIERR",1)_U_ERR("DIERR",1,"TEXT",1),1:"")
+10 ; Delete an entry from a file
DELETE(DIK,DA) ;EP
+1 NEW CREF,X,Y
+2 IF DIK=+DIK
SET DIK=$$ROOT^DILFD(DIK)
+3 SET CREF=$$CREF^DILF(DIK)
+4 DO ^DIK
+5 QUIT $SELECT($DATA(@CREF@(DA)):$$ERR(1060,$PIECE($GET(@CREF@(0),"UNKNOWN"),U)),1:"")
+6 ; Check and validate visit
CHKVISIT(VIEN,DFN,CAT) ;EP
+1 NEW RET,X0
+2 SET RET=$$ISLOCKED^BEHOENCX(VIEN)
+3 IF RET
QUIT $SELECT(RET<0:$$ERR(1003),1:$$ERR(1061))
+4 SET X0=$GET(^AUPNVSIT(VIEN,0))
+5 IF $GET(DFN)
IF $PIECE(X0,U,5)'=DFN
SET RET=$$ERR(1062)
+6 IF '$TEST
IF $PIECE(X0,U,11)
SET RET=$$ERR(1063)
+7 IF '$TEST
IF $LENGTH($GET(CAT))
IF CAT'[$PIECE(X0,U,7)
SET RET=$$ERR(1064,$$EXTERNAL^DILFD(9000010,.07,,$PIECE(X0,U,7)))
+8 QUIT RET
+9 ; Get primary provider for a visit
+10 ; VIEN = Visit IEN
+11 ; Returns Provider IEN ^ Provider Name ^ V Provider IEN
PRIPRV(VIEN) ;EP
+1 NEW X,RET
+2 IF 'VIEN
QUIT $$ERR(1002)
+3 SET X=0
SET RET=$$ERR(1065)
+4 FOR
SET X=$ORDER(^AUPNVPRV("AD",VIEN,X))
IF 'X
QUIT
Begin DoDot:1
+5 SET Y=$GET(^AUPNVPRV(X,0))
+6 IF $PIECE(Y,U,4)="P"
SET RET=$PIECE(Y,U)_U_$PIECE($GET(^VA(200,+Y,0)),U)_U_X
End DoDot:1
IF RET>0
QUIT
+7 QUIT RET
+8 ; Create an historical visit
MAKEHIST(DFN,EVNTDT,LOC,VIEN) ;EP
+1 SET EVNTDT=$$CVTDATE(EVNTDT)
+2 IF EVNTDT#100\1=0
SET EVNTDT=EVNTDT+1
+3 IF EVNTDT\1>DT
QUIT $$ERR(1066)
+4 IF $GET(VIEN)
Begin DoDot:1
+5 NEW X,V,L
+6 SET X=$GET(^AUPNVSIT(VIEN,0))
SET L=$GET(^(21))
SET V=VIEN
SET VIEN=0
+7 IF DFN'=$PIECE(X,U,5)
QUIT
+8 IF $PIECE(X,U,7)'="E"
QUIT
+9 IF X\1'=EVNTDT
IF +X'=EVNTDT
QUIT
+10 IF LOC=+LOC
IF $PIECE(X,U,6)'=LOC
QUIT
+11 IF '$TEST
IF $LENGTH(LOC)
IF $PIECE(L,U)'=LOC
IF $$GET1^DIQ(4,$PIECE(X,U,6),.01)'=LOC
QUIT
+12 SET VIEN=V
End DoDot:1
IF VIEN
QUIT VIEN
+13 QUIT $$FNDVIS^BEHOENCX(DFN,EVNTDT,"E","",-1,,LOC)
+14 ; Convert date to internal format
CVTDATE(X) ;EP
+1 IF "@"[X
QUIT X
+2 IF X?1.E1" "1.2N1"
SET X=$PIECE(X," ")_"@"_$PIECE(X," ",2,99)
+3 DO DT^DILF("PT",X,.X)
+4 QUIT $SELECT(X>0:X,1:"")
+5 ; Convert date to MM/DD/YYYY format
+6 ; If TM is nonzero, include time portion
FMTDATE(X,TM) ;EP
+1 IF 'X
QUIT ""
+2 NEW M,D,V
+3 SET V=$TRANSLATE($$FMTE^XLFDT(X,$SELECT($GET(TM):"5ZM",1:"5ZD")),"@"," ")
+4 QUIT V
+5 ;S M=$E(X,4,5),D=$E(X,6,7),V=$E(X,1,3)+1700
+6 ;S:M&D V=D_"/"_V
+7 ;S:M V=M_"/"_V
+8 ;I $G(TM) D
+9 ;.S X=X#1
+10 ;.Q:'X
+11 ;.S X=$TR($J(X*10000\1,4),0)
+12 ;.S V=V_" "_$E(X,1,2)_":"_$E(X,3,4)
+13 ;Q V
+14 ; Convert a string to WP format
TOWP(X) ;EP
+1 NEW I,L,L2,Y,Z
+2 SET Y=@X
+3 KILL @X
+4 IF Y="@"
SET Y=""
+5 FOR I=1:1
IF '$LENGTH(Y)
QUIT
Begin DoDot:1
+6 SET L=$FIND(Y,$CHAR(13))
+7 IF 'L!(L>242)
Begin DoDot:2
+8 SET L=$SELECT($LENGTH(Y)'>240:999,1:0)
+9 FOR
SET L2=$FIND(Y," ",L)
IF 'L2!(L2>242)
QUIT
SET L=L2
End DoDot:2
+10 IF 'L
SET Z=$EXTRACT(Y,1,240)
SET Y=$EXTRACT(Y,241,99999)
+11 IF '$TEST
SET Z=$EXTRACT(Y,1,L-2)
SET Y=$EXTRACT(Y,L,99999)
+12 SET @X@(I,0)=$TRANSLATE(Z,$CHAR(13,10))
End DoDot:1
+13 QUIT $SELECT($DATA(@X):X,1:"")
+14 ; Convert a value to internal format
TOINTRNL(FNUM,FLD,VAL) ;EP
+1 NEW RET
+2 DO CHK^DIE(FNUM,FLD,,VAL,.RET)
+3 QUIT $SELECT(U[$GET(RET):"",1:RET)
+4 ; Return an error code/error dialog
ERR(CODE,PARAMS) ;EP
+1 QUIT -CODE_U_$$EZBLD^DIALOG(CODE+903620000,.PARAMS)
+2 ; Return a temporary global reference
TMPGBL(X) ;EP
+1 KILL ^TMP("BGO"_$GET(X),$JOB)
QUIT $NAME(^($JOB))
+2 ; Returns status of screen application
+3 ; 0=failed 1=passed
XSCRN(IEN,SCRN) ;EP
+1 NEW S,X,Y,I,J,FLD,OPR,VAL,N,P
+2 ; Default to passed
SET X=1
+3 IF SCRN'=""
Begin DoDot:1
+4 IF $EXTRACT(SCRN,1,2)="I "
Begin DoDot:2
+5 SET Y=IEN
XECUTE SCRN
SET X=$TEST
End DoDot:2
+6 IF '$TEST
Begin DoDot:2
+7 FOR I=1:1
SET S=$PIECE(SCRN,"&",I)
IF S=""
QUIT
Begin DoDot:3
+8 SET FLD=+S
SET X=0
+9 IF 'FLD
QUIT
+10 SET OPR=""
+11 FOR J=1:1:3
IF "=<>'[]"'[$EXTRACT(S,$LENGTH(FLD)+J)
QUIT
SET OPR=OPR_$EXTRACT(S,$LENGTH(FLD)+J)
+12 IF OPR=""
QUIT
+13 SET VAL=$PIECE(S,OPR,2,999)
+14 SET N=$PIECE($GET(^DD(FNUM,FLD,0)),U,4)
SET P=$PIECE(N,";",2)
SET N=$PIECE(N,";")
+15 IF N=""!(P="")
QUIT
+16 XECUTE "S X=$P($G(@GBL@(IEN,N)),U,P)"_OPR_"VAL"
End DoDot:3
IF 'X
QUIT
End DoDot:2
End DoDot:1
+17 QUIT X
