BEHOENPC ;MSC/IND/DKM - PCC Data Management ;19-Feb-2015 10:05;PLS
;;1.1;BEH COMPONENTS;**005003,005004,005005,005006,005007,005008,005009,005010,005011,005012**;Sep 18, 2007
;=================================================================
; RPC: Update PCC data
; DATA = Returned as 0 if successful
; PCC = Array of PCC data to process
; X,Y = Not used (but required)
SAVE(DATA,PCC,X,Y) ;EP
N IDX,TYP,CODE,VIEN,VCAT,VLOC,VDAT,VOLOC,ADD,DEL,VAL,DFN,PRV,FLD,DAT,COM,VMSR,PRIEN,RET
S IDX=0,DATA=0,PRV=0,X=$G(X)
F S IDX=$O(PCC(IDX)) Q:'IDX!DATA D
.S VAL=PCC(IDX),TYP=$P(VAL,U),CODE=$P(VAL,U,2),ADD=TYP["+",DEL=TYP["-",TYP=$TR(TYP,"+-")
.D LOOK("COM",.COM)
.I TYP?1.3AN,$T(@TYP)'="" D @TYP
Q
; Look ahead for modifiers
; TYP = modifier type
; ARY = array to receive data
LOOK(TYP,ARY) ;
K ARY
N IDX2,CNT
S IDX2=IDX
F CNT=0:1 S IDX2=$O(PCC(IDX2)) Q:'IDX2 Q:$P(PCC(IDX2),U)'=TYP D
.I CNT S ARY(CNT)=PCC(IDX2)
.E S ARY=PCC(IDX2)
.S IDX=IDX2
Q
SET(FLN,PC,CV) ;
S PC=$P(VAL,U,PC),FLD(FLN)=$S($D(CV):$$SET^CIAU(PC,CV),$L(PC):PC,1:"@")
Q
; Find an existing V file entry
; CRT = Scalar or array of additional criteria in (field|format|value) format
FIND(FN,CODE,VIEN,CRT) ;
N GBL,IEN,PC
S GBL=$$ROOT^DILFD(FN,,1),IEN=0,PC=$S(FN=120.5:3,1:1)
S:$L($G(CRT)) CRT(-1)=CRT
F S IEN=+$O(@GBL@("AD",VIEN,IEN)) Q:'IEN Q:$P($G(@GBL@(IEN,0)),U,PC)=CODE&$$EVAL(.CRT)
Q IEN
; Evaluate list of additional fields and values
EVAL(ARY) ;
N LP,RES,ITM,TYP,FLD
S RES=1,LP=""
F S LP=$O(CRT(LP)) Q:LP="" D Q:'RES
.S ITM=CRT(LP),FLD=$P(ITM,"|"),TYP=$P(ITM,"|",2),TYP=$S($L(TYP):TYP,1:"E"),ITM=$P(ITM,"|",3,99)
.I FLD=.001 S RES=IEN=ITM
.E S RES=$$GET1^DIQ(FN,IEN,FLD,TYP)=ITM
Q RES
; Store the data in the specified V file
; FN = Fractional portion of V file file #
; CF = Field # of comment field (0=none; defaults to 81101)
; CRT = Additional lookup criteria
; NEW = Returned as true if entry is new
STORE(FN,CF,CRT,NEW) ;
N BEHFLD,BEHERR,BEHIEN,IEN,DELX,BPRV
S NEW=0
S:'$G(VIEN) VIEN=$$FNDVIS^BEHOENCX(DFN,VDAT,VCAT,VLOC,1,,.VOLOC)
I VIEN'>0 S:'DEL DATA=VIEN,VIEN="" G STXIT
G:'$G(FN) STXIT
I $$ISLOCKED^BEHOENCX(VIEN) S DATA="-1^The data associated with this visit may no longer be modified." Q
S:FN<1 FN=9000010+FN
S:'$D(CF) CF=81101
I ADD S IEN="+1",NEW=1
E S IEN=$$FIND(FN,CODE,VIEN,.CRT) I 'IEN G:DEL STXIT S IEN="+1",NEW=1
S:'$D(FLD(.01)) FLD(.01)=$S(DEL:"@",1:CODE)
S:DEL DELX=$$ROOT^DILFD(FN,,1),DELX=$S($L(DELX):$G(@DELX@(IEN,0)),1:"")
S FLD(.02)=DFN
I FN=120.5 D
.S FLD(9000010)=VIEN
E D
.S FLD(.03)=VIEN
.S:CF&$D(COM) FLD(CF)=$P(COM,U,3,999)
.I '$D(FLD(1204)),VCAT'="E" S FLD(1204)=DUZ
.S:'$D(FLD(1201))&$G(DAT) FLD(1201)=DAT
.I NEW=1 S FLD(1216)=$$NOW^XLFDT,FLD(1217)=DUZ
.S FLD(1218)=$$NOW^XLFDT,FLD(1219)=DUZ
;Modified 7/6/2012 for ehr 11
I TYP="PRV"&($G(FLD(.04))="P") D
.S BPRV="" F S BPRV=$O(^AUPNVPRV("AD",VIEN,BPRV)) Q:BPRV="" D
..Q:FLD(.01)=$P($G(^AUPNVPRV(BPRV,0)),U,1)
..I $P($G(^AUPNVPRV(BPRV,0)),U,4)="P" D
...N FLD S FLD(.04)="S"
...M BEHFLD(FN,BPRV_",")=FLD
M BEHFLD(FN,IEN_",")=FLD
K FLD
D UPDATE^DIE("","BEHFLD","BEHIEN","BEHERR")
S:$G(DIERR) DATA=-BEHERR("DIERR",1)_U_BEHERR("DIERR",1,"TEXT",1)
S:$G(BEHIEN(1)) IEN=$G(BEHIEN(1))
D VFEVT(FN,IEN,$S(DEL:2,1:'NEW),.DELX)
STXIT Q:$Q $G(IEN)
Q
; Fire V file update events
; FNUM = V File #
; VFIEN = V File IEN
; OPR = Operation (0 = add, 1 = edit, 2 = delete)
VFEVT(FNUM,VFIEN,OPR,X) ;EP
N ID,GBL,DFN,VIEN,DATA
S GBL=$$ROOT^DILFD(FNUM,,1)
Q:'$L(GBL)
S ID=$P(GBL,"AUPNV",2)
S:'$D(X) X=$G(@GBL@(VFIEN,0))
S DFN=$P(X,U,2),VIEN=$P(X,U,3),DATA=VFIEN_U_$G(CIA("UID"))_U_OPR_U_$P(X,U)_U_VIEN
I ID="AST" D
.D:VIEN BRDCAST^CIANBEVT("VISIT."_VIEN_".POV",DATA)
D:DFN BRDCAST^CIANBEVT("PCC."_DFN_"."_ID,DATA)
D:VIEN BRDCAST^CIANBEVT("VISIT."_VIEN_"."_ID,DATA)
D:VIEN VFMOD(VIEN)
Q
; Update the visit modification date
VFMOD(AUPNVSIT) ;
N DIE,DA,DR,DIU,DIV
D:DUZ("AG")="I" MOD^AUPNVSIT
Q
HDR ;; Visit string
N X
S X=$P(VAL,U,4),VLOC=+X,VDAT=$P(X,";",2),VCAT=$P(X,";",3),VIEN=$P(X,";",4)
S:'(VDAT\1#100) VDAT=VDAT+1
S:'(VDAT\100#100) VDAT=VDAT+100
Q
VST ;; Patient and encounter date
N X
S X=$P(VAL,U,3)
I CODE="PT" S DFN=+X
E I CODE="DT" S DAT=+X
E I CODE="VC" S VCAT=X
E I CODE="OL" S VOLOC=$S(X:X,1:$P(VAL,U,4))
Q
PRV ;; Provider
; PRV[1]^ien[2]^^^name[5]^primary/secondary flag[6]
N BPRV
S PRV=+CODE,ADD=0
D:PRV>0 SET(.04,6,"1:P;0:S;:@"),STORE(.06)
Q
POV ;; Purpose of visit
;POV[1]^code[2]^^narrative[4]^^P/S[6]^^Add to problem list[8] ^ SNOMED CONC CT [9] ^ Provider text [10]
N NAR,VAL1,SNO,DESC,X,PROB,CODE,TXT,FIVE
;IHS/MSC/MGH updated to use correct lookup
;S CODE=$$FIND1^DIC(80,,"X",CODE_" ","BA")
;MGH fix for adding SNOMED codes to POV
S SNO=$P(VAL,U,9)
S CODE=$P(VAL,U,2)
;IHS/MSC/MGH EHR patch 14 Change to using AUPN call to select current
S X=$$CONC^AUPNSICD(SNO_"^^^1")
;S X=$$CONC^BSTSAPI(SNO_"^^^1")
S DESC=$P(X,U,3)
S FIVE=$P(X,U,5)
;IHS/MSC/MGH changed to accomodate special cases
I +X S CODE=$P(FIVE,";",1)
S $P(VAL,U,2)=CODE
S $P(VAL,U,11)=DESC
S TXT=$P(VAL,U,10)
;S CODE=$P(CODE,":",1)
I $$AICD S CODE=$P($$CODEN^ICDEX(CODE,80),"~",1)
E S CODE=+$$CODEN^ICDCODE(CODE,80)
Q:CODE'>0
;S NAR=$$NARR($P(VAL,U,4))
S $P(VAL,U,4)=$$NARR(TXT_"|"_DESC)
S NAR=$P(VAL,U,4)
S VAL1=$P(VAL,U,2)
;IHS/MSC/MGH add problem to problem list if its not already there
S PROB=$$PROBLST^BEHOENP2(SNO,FIVE)
S $P(VAL,U,12)=PROB
D SET(.04,4),SET(.12,6,"1:P;0:S;:@"),SET(.08,7),SET(1101,9),SET(1102,11),SET(.16,12),STORE(.07)
;Add any additional ICD codes as POVs
D ADDICD^BEHOENP2(.RET,.VAL,FIVE,PROB)
Q
CPT ;; CPT codes
;IHS/MSC/MGH fix for patch 9
S CODE=$P(CODE,":",1)
;IHS/MSC/MGH HOTFIX make sure we have the IEN and not just the code
S CODE=$$CODEN^ICPTCOD(CODE)
S CODE=+$$CPT^ICPTCOD(CODE)
D:CODE>0 SET(.16,7),STORE(.18)
Q
IMM ;; Immunizations
; TIMM[1]^Code[2]^Cat[3]^Nar[4]^Com[5]^Prv[6]^Series[7]^Reaction[8]^
; Contraindicated[9]^Refused[10]^LotNum[11]^Site[12]^Volume[13]^
; VISDate[14] ^ VFC Elig [15] ^ Admin notes [16]
N REF,LOT,NEW,OFF
;MSC/MGH added offset for Vista/RPMS field conflicts
;MSC/MGH Patch 13 added VFC elig
S OFF=$S($G(DUZ("AG"))="I":0,1:9999999)
S REF=$P(VAL,U,10),LOT="",NEW=0
I $G(VIEN),$P($G(^AUPNVSIT(VIEN,0)),U,7)'="E" S LOT=$P(VAL,U,11)
I $L(REF) D STORE(),REFUSAL("IMMUNIZATION",REF) Q:REF'="@"
D SET(.04,7),SET(.06,8),SET(.07,9),SET(.05,11),SET(.09+OFF,12)
D SET(.11+OFF,13),SET(.12+OFF,14),SET(.14+OFF,15),SET(1+OFF,16)
Q:$$STORE(.11,,,.NEW)'>0
I NEW,LOT,$L($T(LOTDECR^BIRPC3)) D LOTDECR^BIRPC3(LOT)
I $P(VAL,U,9),$L($T(SETCONT^BGOVIMM2)) D
.N X
.S X=$P(VAL,U,8),X=$S(X=12:1,X=6:3,X=7:5,X=9:4,1:10)
.D SETCONT^BGOVIMM2(,DFN_U_CODE_U_X)
Q
SK ;; Skin tests
; SK[1]^Code[2]^Cat[3]^Nar[4]^Com[5]^Prv[6]^result[7]^reading[8]^
; d/t read[9]^d/t given[10]^read by[11]^refused[12]^site[13]^vol[14]
N REF,GVN,DTR,DTG,TODAY,ERR,OFF,GTR
;MSC/MGH added offset for Vista/RPMS field conflicts
S OFF=$S($G(DUZ("AG"))="I":0,1:9999999)
S TODAY=$$DT^XLFDT()
S DTR=$P($P(VAL,U,9),".")
S GTR=$P(VAL,U,10)
I (GTR>$$NOW^XLFDT)!(DTR>TODAY) S DATA="-1^You cannot enter dates in the future" Q
I +DTR,GTR>DTR S DATA="-1^The skin test read date must be after the applied date" Q
S REF=$P(VAL,U,12),GVN=$P(VAL,U,10)
S:'$L(GVN) (GVN,$P(VAL,U,10))=$G(VDAT)
I GVN,GVN\1'=(VDAT\1) N VDAT,VCAT,VLOC,VOLOC,VIEN D
.S VDAT=GVN,VCAT="E",VLOC="" ; Force historical visit
I $L(REF) D STORE(),REFUSAL("SKIN TEST",REF) Q:REF'="@"
I $P(VAL,U,7)="N" D
.I $P(VAL,U,8)=""!($P(VAL,U,8)="@") S $P(VAL,U,8)=0
D SET(.04,7),SET(.05,8),SET(.06,9),SET(1201,10),SET(.08+OFF,11),SET(.09+OFF,13),SET(.11+OFF,14),STORE(.12)
Q
PED ;; Patient education
; PED[1]^Code[2]^Cat[3]^Nar[4]^Com[5]^Prv[6]^level of understanding[7]^
; refused[8]^elapsed[9]^setting[10]^goals[11]^outcome[12]^Readiness to learn[13]
N REF
S REF=$P(VAL,U,8)
I "@"[REF,$P(VAL,U,7)=5 S REF="R"
D:$L(REF) STORE(),REFUSAL("EDUCATION TOPICS",REF)
S:'$P(VAL,U,6) $P(VAL,U,6)=DUZ ;Patch 003
S $P(VAL,U,3)=$$PEDTOPIC($P(VAL,U,3)) ;Patch 004
S:"@"'[REF $P(VAL,U,7)=5
D SET(.12,3),SET(.05,6),SET(.06,7),SET(.08,9),SET(.07,10),SET(.13,11),SET(.14,12),SET(1102,13),STORE(.16,.11)
Q
HF ;; Health factors
; HF[1]^Code[2]^Cat[3]^Nar[4]^Com[5]^Prv[6]^level/severity[7]
D SET(.01,2),SET(.04,7),STORE(.23)
Q
ASM ;; Asthma
; ASM[1]^Code[2]^Severity[3]^Asthma Control[4]
S CODE=1
D SET(.14,4),STORE(.41)
Q
XAM ;; Patient exams
; XAM[1]^Code[2]^Cat[3]^Nar[4]^Com[5]^Prv[6]^result[7]^refused[8]
N REF
S REF=$P(VAL,U,8)
I $L(REF) D STORE(),REFUSAL("EXAM",REF) Q:REF'="@"
D SET(.04,7),STORE(.13)
Q
TRT ;; Treatments
; TRT[1]^Code[2]^Cat[3]^Nar[4]^Com[5]^Prv[6]^Qty[7]
D SET(.04,7),STORE(.15)
Q
MSR ;; Vital measurements (new format)
; MSR[1]^Code[2]^Cat[3]^Nar[4]^Com[5]^Prv[6]^Value[7]^Units[8]^
;VMSR IEN[9]^GMRV IEN[10]^When entered[11]^Taken date[12]^Entered by[13]^Qualfier[14]
N GMRV,IEN,WHEN,XM,YM,Z,BEHDATA,TAKEN,ENTER,ENTERIEN,I,QUALNAME,QUALS,RESULT,NEW,QUALCT,SAVEDATA
S ENTERIEN="",SAVEDATA=0
S:'$D(VMSR) VMSR=$$GET^XPAR("ALL","BEHOVM USE VMSR")
S XM=$P(VAL,U,7),YM=$P(VAL,U,8)
I XM="" S DATA=0 Q
;OIT/MSC/MGH Delete is now marked as entered in error
I DEL S BEHDATA=$P(VAL,U,9)_U_DUZ_U_4 D EIE^BEHOVM2(.RESULT,BEHDATA) I RESULT="OK" S DATA=0 Q
;OIT/MSC/MGH Edits are now a delete and make a new entry
I 'ADD D
.S BEHDATA=$P(VAL,U,9)_U_DUZ_U_4 D
..;IHS/MSC/MGH patch 13 line
..I $P(VAL,U,2)=$$VTYPE^BEHOVM("HT") S SAVEDATA=BEHDATA
..D EIE^BEHOVM2(.RESULT,BEHDATA)
.I RESULT="OK" S DATA=0
.E S DATA=1 ;RESULT
.S ADD=1,$P(VAL,U,9)=0
Q:DATA
I 'DEL,$L(YM) D
.S DATA=$$NORM^BEHOVM(CODE,.XM,.YM,VMSR)
.S:'DATA $P(VAL,U,7)=XM,$P(VAL,U,8)=YM
Q:DATA
S GMRV=$P(VAL,U,10),IEN=$P(VAL,U,9)
;S:'WHEN WHEN=$$NOW^XLFDT() ;Patch 003
S WHEN=$$NOW^XLFDT()
S TAKEN=$P(VAL,U,12),TAKEN=$$CVTDATE^BGOUTL(TAKEN)
I TAKEN="" S TAKEN=$P(VAL,U,11),TAKEN=$$CVTDATE^BGOUTL(TAKEN)
;IHS/MSC/MGH Change for EHR patch 9
I TAKEN=""&(VCAT="E") S TAKEN=VDAT
I TAKEN="" S TAKEN=WHEN
S ENTERIEN=$P(VAL,U,13)
I ENTERIEN="" S ENTERIEN=DUZ
S $P(VAL,U,6)=DUZ ;Patch 003
I VMSR D
.D SET(.04,7),SET(1204,6)
.D FIELD^DID(9000010.01,.07,"","DESCRIPTION","NEW")
.S FLD(1201)=TAKEN,FLD(.08)=ENTERIEN
.S FLD(.07)=WHEN
.S IEN=$$STORE(.01,,$S(IEN:".001||"_IEN,1:""))
.I GMRV,IEN!DEL D
..N BEHFLD
..S BEHFLD(120.5,GMRV_",",9999999)=$S(DEL:"@",1:IEN)
..D UPDATE^DIE("","BEHFLD")
E D
.D SET(1.2,7),SET(.06,6),SET(.03,2)
.S TAKEN=$P(VAL,U,12),TAKEN=$$CVTDATE^BGOUTL(TAKEN)
.I TAKEN="" S TAKEN=$P(VAL,U,11),TAKEN=$$CVTDATE^BGOUTL(TAKEN)
.I TAKEN="" S TAKEN=$$NOW^XLFDT
.S FLD(.01)=$S(DEL:"@",1:TAKEN),FLD(.04)=$$NOW^XLFDT,FLD(.05)=VLOC
.S IEN=$$STORE(120.5,,$S(IEN:".001||"_IEN,1:""))
I IEN&($P(VAL,U,14)'="") D
.K QUAL
.S QUALS=$P(VAL,U,14)
.;IHS/MSC/MGH Update for qualifiers EHR 11
.I $P($G(^AUTTMSR(CODE,0)),U,1)="O2" D PO2^BEHOVM2(.RESULT,IEN,QUALS) Q
.S QUALCT=$L(QUALS,"~")
.F I=1:1:QUALCT S QUALNAME=$P(QUALS,"~",I) D
..Q:QUALNAME=""
..S QUAL(QUALNAME)=""
.D QUAL^BEHOVM2(.RESULT,IEN,.QUAL)
;IHS/MSC/MGH Patch 13 changed for storing BMI
I 'DEL D BMICALC^BEHOVM5(IEN)
;I $P($G(^AUTTMSR(CODE,0)),U,1)="WT" D
;.D BMISAVE^BEHOVM4(.RET,DFN,XM,TAKEN,VIEN) ;Store the BMI based on wt
;I +SAVEDATA D DELBMIS^BEHOVM4($P(SAVEDATA,U,1),DFN)
Q
VIT ;; Vital measurements (old format)
S TYP="MSR"
S VAL="MSR^"_CODE_"^^^^"_$P(VAL,U,6)_U_$P(VAL,U,5)_U_$P(VAL,U,7)_U_$P(VAL,U,3)_U_$P(VAL,U,4)_U_$P(VAL,U,8)_U_$P(VAL,U,9)_U_$P(VAL,U,10)_U_$P(VAL,U,11)
D MSR
Q
; Store/update a refusal
REFUSAL(TYPE,RSN) ;
Q:'$L(RSN)!(VIEN'>0)
S TYPE=$$FIND1^DIC(9999999.73,,"X",TYPE)
Q:'TYPE
N FDA,ERR,FNUM,IEN,OPR,DELX,IN,OUT,CT,HIS,X
S FNUM=$P(^AUTTREFT(TYPE,0),U,2),OPR=1
D REFUSAL^BEHOENP1(FNUM,CODE,VIEN,.IEN)
I "@"[RSN Q:'IEN S TYPE="@",OPR=2,DELX=$G(^AUPNPREF(IEN,0))
S:'IEN IEN="+1",OPR=0
S FDA=$NA(FDA(9000022,IEN_","))
S @FDA@(.01)=TYPE
S @FDA@(.02)=DFN
S @FDA@(.03)=^AUPNVSIT(VIEN,0)\1
S @FDA@(.04)=$P(VAL,U,4)
S @FDA@(.05)=FNUM
S @FDA@(.06)=CODE
S @FDA@(.08)=$$NOW^XLFDT
;IHS/MSC/MGH Patch 13 Added for reason
I $L(RSN)>0 D
.S CT=$$GET1^DIQ(9999999.102,RSN,.01)
.S HIS=$$GET1^DIQ(9999999.102,RSN,.04,"I")
.S @FDA@(.07)=HIS
.K ARR
.I CT'="" D
..S IN=CT_"^^^1^"
..S OUT="ARR"
..S @FDA@(1.01)=CT
..S X=$$CNCLKP^BSTSAPI(.OUT,.IN)
..I X>0 D
...S @FDA@(1.02)=ARR(1,"PRE","DSC")
;END patch 13 mod
I $E(IEN)="+" D
.S @FDA@(1216)=$$NOW^XLFDT
.S @FDA@(1217)=DUZ
S @FDA@(1218)=$$NOW^XLFDT
S @FDA@(1219)=DUZ
D UPDATE^DIE("","FDA","IEN","ERR")
Q:$D(ERR("DIERR"))
S:'OPR IEN=IEN(1)
D REFEVT(IEN,OPR,.DELX)
Q
; Broadcast a refusal event
REFEVT(IEN,OPR,X) ;EP
N DFN,TYPE
S:'$D(X) X=$G(^AUPNPREF(IEN,0))
S DFN=$P(X,U,2)
Q:'DFN
S TYPE=$P($G(^AUTTREFT(+X,0)),U)
D BRDCAST^CIANBEVT("REFUSAL."_DFN_"."_TYPE,IEN_U_$G(CIA("UID"))_U_OPR)
Q
; Lookup and optionally add narrative
; Returns pointer to PROVIDER NARRATIVE file
NARR(DESCT) ;
N IEN,TRC,NARR,FDA,TXT
Q:'$L(DESCT) ""
;S DESCT=$$STRPNAR(DESCT) ;P14
S TXT=$E(DESCT,1,160),TRC=$E(DESCT,1,30)
;S TXT="|"_DESCT
F IEN=0:0 S IEN=$O(^AUTNPOV("B",TRC,IEN)) Q:'IEN Q:$P($G(^AUTNPOV(IEN,0)),U)=TXT
Q:IEN IEN
S FDA(9999999.27,"+1,",.01)=TXT
D UPDATE^DIE("E","FDA","IEN","ERR")
Q $G(IEN(1))
UPPER(X) ; Convert lower case X to UPPER CASE
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
; Lookup Education Topic and return pointer if text passed
PEDTOPIC(TOP) ;EP
Q:TOP=+TOP TOP
N TIEN
S TIEN=$$FIND1^DIC(9001002.5,,"X",TOP)
Q $S(TIEN>0:+TIEN,1:"")
;Strip out leading punctuation characters from Provider Narrative text
STRPNAR(NARR) ;EP-
N LP,C,FLG
F LP=1:1:$L(NARR) S C=$E(NARR,LP) I '(C?1P) S FLG=1 Q
Q $S($G(FLG):$E(NARR,LP,$L(NARR)),1:"")
AICD() ;EP
Q $S($$VERSION^XPDUTL("AICD")<"4.0":0,1:1)
BEHOENPC ;MSC/IND/DKM - PCC Data Management ;19-Feb-2015 10:05;PLS
+1 ;;1.1;BEH COMPONENTS;**005003,005004,005005,005006,005007,005008,005009,005010,005011,005012**;Sep 18, 2007
+2 ;=================================================================
+3 ; RPC: Update PCC data
+4 ; DATA = Returned as 0 if successful
+5 ; PCC = Array of PCC data to process
+6 ; X,Y = Not used (but required)
SAVE(DATA,PCC,X,Y) ;EP
+1 NEW IDX,TYP,CODE,VIEN,VCAT,VLOC,VDAT,VOLOC,ADD,DEL,VAL,DFN,PRV,FLD,DAT,COM,VMSR,PRIEN,RET
+2 SET IDX=0
SET DATA=0
SET PRV=0
SET X=$GET(X)
+3 FOR
SET IDX=$ORDER(PCC(IDX))
IF 'IDX!DATA
QUIT
Begin DoDot:1
+4 SET VAL=PCC(IDX)
SET TYP=$PIECE(VAL,U)
SET CODE=$PIECE(VAL,U,2)
SET ADD=TYP["+"
SET DEL=TYP["-"
SET TYP=$TRANSLATE(TYP,"+-")
+5 DO LOOK("COM",.COM)
+6 IF TYP?1.3AN
IF $TEXT(@TYP)'=""
DO @TYP
End DoDot:1
+7 QUIT
+8 ; Look ahead for modifiers
+9 ; TYP = modifier type
+10 ; ARY = array to receive data
LOOK(TYP,ARY) ;
+1 KILL ARY
+2 NEW IDX2,CNT
+3 SET IDX2=IDX
+4 FOR CNT=0:1
SET IDX2=$ORDER(PCC(IDX2))
IF 'IDX2
QUIT
IF $PIECE(PCC(IDX2),U)'=TYP
QUIT
Begin DoDot:1
+5 IF CNT
SET ARY(CNT)=PCC(IDX2)
+6 IF '$TEST
SET ARY=PCC(IDX2)
+7 SET IDX=IDX2
End DoDot:1
+8 QUIT
SET(FLN,PC,CV) ;
+1 SET PC=$PIECE(VAL,U,PC)
SET FLD(FLN)=$SELECT($DATA(CV):$$SET^CIAU(PC,CV),$LENGTH(PC):PC,1:"@")
+2 QUIT
+3 ; Find an existing V file entry
+4 ; CRT = Scalar or array of additional criteria in (field|format|value) format
FIND(FN,CODE,VIEN,CRT) ;
+1 NEW GBL,IEN,PC
+2 SET GBL=$$ROOT^DILFD(FN,,1)
SET IEN=0
SET PC=$SELECT(FN=120.5:3,1:1)
+3 IF $LENGTH($GET(CRT))
SET CRT(-1)=CRT
+4 FOR
SET IEN=+$ORDER(@GBL@("AD",VIEN,IEN))
IF 'IEN
QUIT
IF $PIECE($GET(@GBL@(IEN,0)),U,PC)=CODE&$$EVAL(.CRT)
QUIT
+5 QUIT IEN
+6 ; Evaluate list of additional fields and values
EVAL(ARY) ;
+1 NEW LP,RES,ITM,TYP,FLD
+2 SET RES=1
SET LP=""
+3 FOR
SET LP=$ORDER(CRT(LP))
IF LP=""
QUIT
Begin DoDot:1
+4 SET ITM=CRT(LP)
SET FLD=$PIECE(ITM,"|")
SET TYP=$PIECE(ITM,"|",2)
SET TYP=$SELECT($LENGTH(TYP):TYP,1:"E")
SET ITM=$PIECE(ITM,"|",3,99)
+5 IF FLD=.001
SET RES=IEN=ITM
+6 IF '$TEST
SET RES=$$GET1^DIQ(FN,IEN,FLD,TYP)=ITM
End DoDot:1
IF 'RES
QUIT
+7 QUIT RES
+8 ; Store the data in the specified V file
+9 ; FN = Fractional portion of V file file #
+10 ; CF = Field # of comment field (0=none; defaults to 81101)
+11 ; CRT = Additional lookup criteria
+12 ; NEW = Returned as true if entry is new
STORE(FN,CF,CRT,NEW) ;
+1 NEW BEHFLD,BEHERR,BEHIEN,IEN,DELX,BPRV
+2 SET NEW=0
+3 IF '$GET(VIEN)
SET VIEN=$$FNDVIS^BEHOENCX(DFN,VDAT,VCAT,VLOC,1,,.VOLOC)
+4 IF VIEN'>0
IF 'DEL
SET DATA=VIEN
SET VIEN=""
GOTO STXIT
+5 IF '$GET(FN)
GOTO STXIT
+6 IF $$ISLOCKED^BEHOENCX(VIEN)
SET DATA="-1^The data associated with this visit may no longer be modified."
QUIT
+7 IF FN<1
SET FN=9000010+FN
+8 IF '$DATA(CF)
SET CF=81101
+9 IF ADD
SET IEN="+1"
SET NEW=1
+10 IF '$TEST
SET IEN=$$FIND(FN,CODE,VIEN,.CRT)
IF 'IEN
IF DEL
GOTO STXIT
SET IEN="+1"
SET NEW=1
+11 IF '$DATA(FLD(.01))
SET FLD(.01)=$SELECT(DEL:"@",1:CODE)
+12 IF DEL
SET DELX=$$ROOT^DILFD(FN,,1)
SET DELX=$SELECT($LENGTH(DELX):$GET(@DELX@(IEN,0)),1:"")
+13 SET FLD(.02)=DFN
+14 IF FN=120.5
Begin DoDot:1
+15 SET FLD(9000010)=VIEN
End DoDot:1
+16 IF '$TEST
Begin DoDot:1
+17 SET FLD(.03)=VIEN
+18 IF CF&$DATA(COM)
SET FLD(CF)=$PIECE(COM,U,3,999)
+19 IF '$DATA(FLD(1204))
IF VCAT'="E"
SET FLD(1204)=DUZ
+20 IF '$DATA(FLD(1201))&$GET(DAT)
SET FLD(1201)=DAT
+21 IF NEW=1
SET FLD(1216)=$$NOW^XLFDT
SET FLD(1217)=DUZ
+22 SET FLD(1218)=$$NOW^XLFDT
SET FLD(1219)=DUZ
End DoDot:1
+23 ;Modified 7/6/2012 for ehr 11
+24 IF TYP="PRV"&($GET(FLD(.04))="P")
Begin DoDot:1
+25 SET BPRV=""
FOR
SET BPRV=$ORDER(^AUPNVPRV("AD",VIEN,BPRV))
IF BPRV=""
QUIT
Begin DoDot:2
+26 IF FLD(.01)=$PIECE($GET(^AUPNVPRV(BPRV,0)),U,1)
QUIT
+27 IF $PIECE($GET(^AUPNVPRV(BPRV,0)),U,4)="P"
Begin DoDot:3
+28 NEW FLD
SET FLD(.04)="S"
+29 MERGE BEHFLD(FN,BPRV_",")=FLD
End DoDot:3
End DoDot:2
End DoDot:1
+30 MERGE BEHFLD(FN,IEN_",")=FLD
+31 KILL FLD
+32 DO UPDATE^DIE("","BEHFLD","BEHIEN","BEHERR")
+33 IF $GET(DIERR)
SET DATA=-BEHERR("DIERR",1)_U_BEHERR("DIERR",1,"TEXT",1)
+34 IF $GET(BEHIEN(1))
SET IEN=$GET(BEHIEN(1))
+35 DO VFEVT(FN,IEN,$SELECT(DEL:2,1:'NEW),.DELX)
STXIT IF $QUIT
QUIT $GET(IEN)
+1 QUIT
+2 ; Fire V file update events
+3 ; FNUM = V File #
+4 ; VFIEN = V File IEN
+5 ; OPR = Operation (0 = add, 1 = edit, 2 = delete)
VFEVT(FNUM,VFIEN,OPR,X) ;EP
+1 NEW ID,GBL,DFN,VIEN,DATA
+2 SET GBL=$$ROOT^DILFD(FNUM,,1)
+3 IF '$LENGTH(GBL)
QUIT
+4 SET ID=$PIECE(GBL,"AUPNV",2)
+5 IF '$DATA(X)
SET X=$GET(@GBL@(VFIEN,0))
+6 SET DFN=$PIECE(X,U,2)
SET VIEN=$PIECE(X,U,3)
SET DATA=VFIEN_U_$GET(CIA("UID"))_U_OPR_U_$PIECE(X,U)_U_VIEN
+7 IF ID="AST"
Begin DoDot:1
+8 IF VIEN
DO BRDCAST^CIANBEVT("VISIT."_VIEN_".POV",DATA)
End DoDot:1
+9 IF DFN
DO BRDCAST^CIANBEVT("PCC."_DFN_"."_ID,DATA)
+10 IF VIEN
DO BRDCAST^CIANBEVT("VISIT."_VIEN_"."_ID,DATA)
+11 IF VIEN
DO VFMOD(VIEN)
+12 QUIT
+13 ; Update the visit modification date
VFMOD(AUPNVSIT) ;
+1 NEW DIE,DA,DR,DIU,DIV
+2 IF DUZ("AG")="I"
DO MOD^AUPNVSIT
+3 QUIT
HDR ;; Visit string
+1 NEW X
+2 SET X=$PIECE(VAL,U,4)
SET VLOC=+X
SET VDAT=$PIECE(X,";",2)
SET VCAT=$PIECE(X,";",3)
SET VIEN=$PIECE(X,";",4)
+3 IF '(VDAT\1#100)
SET VDAT=VDAT+1
+4 IF '(VDAT\100#100)
SET VDAT=VDAT+100
+5 QUIT
VST ;; Patient and encounter date
+1 NEW X
+2 SET X=$PIECE(VAL,U,3)
+3 IF CODE="PT"
SET DFN=+X
+4 IF '$TEST
IF CODE="DT"
SET DAT=+X
+5 IF '$TEST
IF CODE="VC"
SET VCAT=X
+6 IF '$TEST
IF CODE="OL"
SET VOLOC=$SELECT(X:X,1:$PIECE(VAL,U,4))
+7 QUIT
PRV ;; Provider
+1 ; PRV[1]^ien[2]^^^name[5]^primary/secondary flag[6]
+2 NEW BPRV
+3 SET PRV=+CODE
SET ADD=0
+4 IF PRV>0
DO SET(.04,6,"1:P;0:S;:@")
DO STORE(.06)
+5 QUIT
POV ;; Purpose of visit
+1 ;POV[1]^code[2]^^narrative[4]^^P/S[6]^^Add to problem list[8] ^ SNOMED CONC CT [9] ^ Provider text [10]
+2 NEW NAR,VAL1,SNO,DESC,X,PROB,CODE,TXT,FIVE
+3 ;IHS/MSC/MGH updated to use correct lookup
+4 ;S CODE=$$FIND1^DIC(80,,"X",CODE_" ","BA")
+5 ;MGH fix for adding SNOMED codes to POV
+6 SET SNO=$PIECE(VAL,U,9)
+7 SET CODE=$PIECE(VAL,U,2)
+8 ;IHS/MSC/MGH EHR patch 14 Change to using AUPN call to select current
+9 SET X=$$CONC^AUPNSICD(SNO_"^^^1")
+10 ;S X=$$CONC^BSTSAPI(SNO_"^^^1")
+11 SET DESC=$PIECE(X,U,3)
+12 SET FIVE=$PIECE(X,U,5)
+13 ;IHS/MSC/MGH changed to accomodate special cases
+14 IF +X
SET CODE=$PIECE(FIVE,";",1)
+15 SET $PIECE(VAL,U,2)=CODE
+16 SET $PIECE(VAL,U,11)=DESC
+17 SET TXT=$PIECE(VAL,U,10)
+18 ;S CODE=$P(CODE,":",1)
+19 IF $$AICD
SET CODE=$PIECE($$CODEN^ICDEX(CODE,80),"~",1)
+20 IF '$TEST
SET CODE=+$$CODEN^ICDCODE(CODE,80)
+21 IF CODE'>0
QUIT
+22 ;S NAR=$$NARR($P(VAL,U,4))
+23 SET $PIECE(VAL,U,4)=$$NARR(TXT_"|"_DESC)
+24 SET NAR=$PIECE(VAL,U,4)
+25 SET VAL1=$PIECE(VAL,U,2)
+26 ;IHS/MSC/MGH add problem to problem list if its not already there
+27 SET PROB=$$PROBLST^BEHOENP2(SNO,FIVE)
+28 SET $PIECE(VAL,U,12)=PROB
+29 DO SET(.04,4)
DO SET(.12,6,"1:P;0:S;:@")
DO SET(.08,7)
DO SET(1101,9)
DO SET(1102,11)
DO SET(.16,12)
DO STORE(.07)
+30 ;Add any additional ICD codes as POVs
+31 DO ADDICD^BEHOENP2(.RET,.VAL,FIVE,PROB)
+32 QUIT
CPT ;; CPT codes
+1 ;IHS/MSC/MGH fix for patch 9
+2 SET CODE=$PIECE(CODE,":",1)
+3 ;IHS/MSC/MGH HOTFIX make sure we have the IEN and not just the code
+4 SET CODE=$$CODEN^ICPTCOD(CODE)
+5 SET CODE=+$$CPT^ICPTCOD(CODE)
+6 IF CODE>0
DO SET(.16,7)
DO STORE(.18)
+7 QUIT
IMM ;; Immunizations
+1 ; TIMM[1]^Code[2]^Cat[3]^Nar[4]^Com[5]^Prv[6]^Series[7]^Reaction[8]^
+2 ; Contraindicated[9]^Refused[10]^LotNum[11]^Site[12]^Volume[13]^
+3 ; VISDate[14] ^ VFC Elig [15] ^ Admin notes [16]
+4 NEW REF,LOT,NEW,OFF
+5 ;MSC/MGH added offset for Vista/RPMS field conflicts
+6 ;MSC/MGH Patch 13 added VFC elig
+7 SET OFF=$SELECT($GET(DUZ("AG"))="I":0,1:9999999)
+8 SET REF=$PIECE(VAL,U,10)
SET LOT=""
SET NEW=0
+9 IF $GET(VIEN)
IF $PIECE($GET(^AUPNVSIT(VIEN,0)),U,7)'="E"
SET LOT=$PIECE(VAL,U,11)
+10 IF $LENGTH(REF)
DO STORE()
DO REFUSAL("IMMUNIZATION",REF)
IF REF'="@"
QUIT
+11 DO SET(.04,7)
DO SET(.06,8)
DO SET(.07,9)
DO SET(.05,11)
DO SET(.09+OFF,12)
+12 DO SET(.11+OFF,13)
DO SET(.12+OFF,14)
DO SET(.14+OFF,15)
DO SET(1+OFF,16)
+13 IF $$STORE(.11,,,.NEW)'>0
QUIT
+14 IF NEW
IF LOT
IF $LENGTH($TEXT(LOTDECR^BIRPC3))
DO LOTDECR^BIRPC3(LOT)
+15 IF $PIECE(VAL,U,9)
IF $LENGTH($TEXT(SETCONT^BGOVIMM2))
Begin DoDot:1
+16 NEW X
+17 SET X=$PIECE(VAL,U,8)
SET X=$SELECT(X=12:1,X=6:3,X=7:5,X=9:4,1:10)
+18 DO SETCONT^BGOVIMM2(,DFN_U_CODE_U_X)
End DoDot:1
+19 QUIT
SK ;; Skin tests
+1 ; SK[1]^Code[2]^Cat[3]^Nar[4]^Com[5]^Prv[6]^result[7]^reading[8]^
+2 ; d/t read[9]^d/t given[10]^read by[11]^refused[12]^site[13]^vol[14]
+3 NEW REF,GVN,DTR,DTG,TODAY,ERR,OFF,GTR
+4 ;MSC/MGH added offset for Vista/RPMS field conflicts
+5 SET OFF=$SELECT($GET(DUZ("AG"))="I":0,1:9999999)
+6 SET TODAY=$$DT^XLFDT()
+7 SET DTR=$PIECE($PIECE(VAL,U,9),".")
+8 SET GTR=$PIECE(VAL,U,10)
+9 IF (GTR>$$NOW^XLFDT)!(DTR>TODAY)
SET DATA="-1^You cannot enter dates in the future"
QUIT
+10 IF +DTR
IF GTR>DTR
SET DATA="-1^The skin test read date must be after the applied date"
QUIT
+11 SET REF=$PIECE(VAL,U,12)
SET GVN=$PIECE(VAL,U,10)
+12 IF '$LENGTH(GVN)
SET (GVN,$PIECE(VAL,U,10))=$GET(VDAT)
+13 IF GVN
IF GVN\1'=(VDAT\1)
NEW VDAT,VCAT,VLOC,VOLOC,VIEN
Begin DoDot:1
+14 ; Force historical visit
SET VDAT=GVN
SET VCAT="E"
SET VLOC=""
End DoDot:1
+15 IF $LENGTH(REF)
DO STORE()
DO REFUSAL("SKIN TEST",REF)
IF REF'="@"
QUIT
+16 IF $PIECE(VAL,U,7)="N"
Begin DoDot:1
+17 IF $PIECE(VAL,U,8)=""!($PIECE(VAL,U,8)="@")
SET $PIECE(VAL,U,8)=0
End DoDot:1
+18 DO SET(.04,7)
DO SET(.05,8)
DO SET(.06,9)
DO SET(1201,10)
DO SET(.08+OFF,11)
DO SET(.09+OFF,13)
DO SET(.11+OFF,14)
DO STORE(.12)
+19 QUIT
PED ;; Patient education
+1 ; PED[1]^Code[2]^Cat[3]^Nar[4]^Com[5]^Prv[6]^level of understanding[7]^
+2 ; refused[8]^elapsed[9]^setting[10]^goals[11]^outcome[12]^Readiness to learn[13]
+3 NEW REF
+4 SET REF=$PIECE(VAL,U,8)
+5 IF "@"[REF
IF $PIECE(VAL,U,7)=5
SET REF="R"
+6 IF $LENGTH(REF)
DO STORE()
DO REFUSAL("EDUCATION TOPICS",REF)
+7 ;Patch 003
IF '$PIECE(VAL,U,6)
SET $PIECE(VAL,U,6)=DUZ
+8 ;Patch 004
SET $PIECE(VAL,U,3)=$$PEDTOPIC($PIECE(VAL,U,3))
+9 IF "@"'[REF
SET $PIECE(VAL,U,7)=5
+10 DO SET(.12,3)
DO SET(.05,6)
DO SET(.06,7)
DO SET(.08,9)
DO SET(.07,10)
DO SET(.13,11)
DO SET(.14,12)
DO SET(1102,13)
DO STORE(.16,.11)
+11 QUIT
HF ;; Health factors
+1 ; HF[1]^Code[2]^Cat[3]^Nar[4]^Com[5]^Prv[6]^level/severity[7]
+2 DO SET(.01,2)
DO SET(.04,7)
DO STORE(.23)
+3 QUIT
ASM ;; Asthma
+1 ; ASM[1]^Code[2]^Severity[3]^Asthma Control[4]
+2 SET CODE=1
+3 DO SET(.14,4)
DO STORE(.41)
+4 QUIT
XAM ;; Patient exams
+1 ; XAM[1]^Code[2]^Cat[3]^Nar[4]^Com[5]^Prv[6]^result[7]^refused[8]
+2 NEW REF
+3 SET REF=$PIECE(VAL,U,8)
+4 IF $LENGTH(REF)
DO STORE()
DO REFUSAL("EXAM",REF)
IF REF'="@"
QUIT
+5 DO SET(.04,7)
DO STORE(.13)
+6 QUIT
TRT ;; Treatments
+1 ; TRT[1]^Code[2]^Cat[3]^Nar[4]^Com[5]^Prv[6]^Qty[7]
+2 DO SET(.04,7)
DO STORE(.15)
+3 QUIT
MSR ;; Vital measurements (new format)
+1 ; MSR[1]^Code[2]^Cat[3]^Nar[4]^Com[5]^Prv[6]^Value[7]^Units[8]^
+2 ;VMSR IEN[9]^GMRV IEN[10]^When entered[11]^Taken date[12]^Entered by[13]^Qualfier[14]
+3 NEW GMRV,IEN,WHEN,XM,YM,Z,BEHDATA,TAKEN,ENTER,ENTERIEN,I,QUALNAME,QUALS,RESULT,NEW,QUALCT,SAVEDATA
+4 SET ENTERIEN=""
SET SAVEDATA=0
+5 IF '$DATA(VMSR)
SET VMSR=$$GET^XPAR("ALL","BEHOVM USE VMSR")
+6 SET XM=$PIECE(VAL,U,7)
SET YM=$PIECE(VAL,U,8)
+7 IF XM=""
SET DATA=0
QUIT
+8 ;OIT/MSC/MGH Delete is now marked as entered in error
+9 IF DEL
SET BEHDATA=$PIECE(VAL,U,9)_U_DUZ_U_4
DO EIE^BEHOVM2(.RESULT,BEHDATA)
IF RESULT="OK"
SET DATA=0
QUIT
+10 ;OIT/MSC/MGH Edits are now a delete and make a new entry
+11 IF 'ADD
Begin DoDot:1
+12 SET BEHDATA=$PIECE(VAL,U,9)_U_DUZ_U_4
Begin DoDot:2
+13 ;IHS/MSC/MGH patch 13 line
+14 IF $PIECE(VAL,U,2)=$$VTYPE^BEHOVM("HT")
SET SAVEDATA=BEHDATA
+15 DO EIE^BEHOVM2(.RESULT,BEHDATA)
End DoDot:2
+16 IF RESULT="OK"
SET DATA=0
+17 ;RESULT
IF '$TEST
SET DATA=1
+18 SET ADD=1
SET $PIECE(VAL,U,9)=0
End DoDot:1
+19 IF DATA
QUIT
+20 IF 'DEL
IF $LENGTH(YM)
Begin DoDot:1
+21 SET DATA=$$NORM^BEHOVM(CODE,.XM,.YM,VMSR)
+22 IF 'DATA
SET $PIECE(VAL,U,7)=XM
SET $PIECE(VAL,U,8)=YM
End DoDot:1
+23 IF DATA
QUIT
+24 SET GMRV=$PIECE(VAL,U,10)
SET IEN=$PIECE(VAL,U,9)
+25 ;S:'WHEN WHEN=$$NOW^XLFDT() ;Patch 003
+26 SET WHEN=$$NOW^XLFDT()
+27 SET TAKEN=$PIECE(VAL,U,12)
SET TAKEN=$$CVTDATE^BGOUTL(TAKEN)
+28 IF TAKEN=""
SET TAKEN=$PIECE(VAL,U,11)
SET TAKEN=$$CVTDATE^BGOUTL(TAKEN)
+29 ;IHS/MSC/MGH Change for EHR patch 9
+30 IF TAKEN=""&(VCAT="E")
SET TAKEN=VDAT
+31 IF TAKEN=""
SET TAKEN=WHEN
+32 SET ENTERIEN=$PIECE(VAL,U,13)
+33 IF ENTERIEN=""
SET ENTERIEN=DUZ
+34 ;Patch 003
SET $PIECE(VAL,U,6)=DUZ
+35 IF VMSR
Begin DoDot:1
+36 DO SET(.04,7)
DO SET(1204,6)
+37 DO FIELD^DID(9000010.01,.07,"","DESCRIPTION","NEW")
+38 SET FLD(1201)=TAKEN
SET FLD(.08)=ENTERIEN
+39 SET FLD(.07)=WHEN
+40 SET IEN=$$STORE(.01,,$SELECT(IEN:".001||"_IEN,1:""))
+41 IF GMRV
IF IEN!DEL
Begin DoDot:2
+42 NEW BEHFLD
+43 SET BEHFLD(120.5,GMRV_",",9999999)=$SELECT(DEL:"@",1:IEN)
+44 DO UPDATE^DIE("","BEHFLD")
End DoDot:2
End DoDot:1
+45 IF '$TEST
Begin DoDot:1
+46 DO SET(1.2,7)
DO SET(.06,6)
DO SET(.03,2)
+47 SET TAKEN=$PIECE(VAL,U,12)
SET TAKEN=$$CVTDATE^BGOUTL(TAKEN)
+48 IF TAKEN=""
SET TAKEN=$PIECE(VAL,U,11)
SET TAKEN=$$CVTDATE^BGOUTL(TAKEN)
+49 IF TAKEN=""
SET TAKEN=$$NOW^XLFDT
+50 SET FLD(.01)=$SELECT(DEL:"@",1:TAKEN)
SET FLD(.04)=$$NOW^XLFDT
SET FLD(.05)=VLOC
+51 SET IEN=$$STORE(120.5,,$SELECT(IEN:".001||"_IEN,1:""))
End DoDot:1
+52 IF IEN&($PIECE(VAL,U,14)'="")
Begin DoDot:1
+53 KILL QUAL
+54 SET QUALS=$PIECE(VAL,U,14)
+55 ;IHS/MSC/MGH Update for qualifiers EHR 11
+56 IF $PIECE($GET(^AUTTMSR(CODE,0)),U,1)="O2"
DO PO2^BEHOVM2(.RESULT,IEN,QUALS)
QUIT
+57 SET QUALCT=$LENGTH(QUALS,"~")
+58 FOR I=1:1:QUALCT
SET QUALNAME=$PIECE(QUALS,"~",I)
Begin DoDot:2
+59 IF QUALNAME=""
QUIT
+60 SET QUAL(QUALNAME)=""
End DoDot:2
+61 DO QUAL^BEHOVM2(.RESULT,IEN,.QUAL)
End DoDot:1
+62 ;IHS/MSC/MGH Patch 13 changed for storing BMI
+63 IF 'DEL
DO BMICALC^BEHOVM5(IEN)
+64 ;I $P($G(^AUTTMSR(CODE,0)),U,1)="WT" D
+65 ;.D BMISAVE^BEHOVM4(.RET,DFN,XM,TAKEN,VIEN) ;Store the BMI based on wt
+66 ;I +SAVEDATA D DELBMIS^BEHOVM4($P(SAVEDATA,U,1),DFN)
+67 QUIT
VIT ;; Vital measurements (old format)
+1 SET TYP="MSR"
+2 SET VAL="MSR^"_CODE_"^^^^"_$PIECE(VAL,U,6)_U_$PIECE(VAL,U,5)_U_$PIECE(VAL,U,7)_U_$PIECE(VAL,U,3)_U_$PIECE(VAL,U,4)_U_$PIECE(VAL,U,8)_U_$PIECE(VAL,U,9)_U_$PIECE(VAL,U,10)_U_$PIECE(VAL,U,11)
+3 DO MSR
+4 QUIT
+5 ; Store/update a refusal
REFUSAL(TYPE,RSN) ;
+1 IF '$LENGTH(RSN)!(VIEN'>0)
QUIT
+2 SET TYPE=$$FIND1^DIC(9999999.73,,"X",TYPE)
+3 IF 'TYPE
QUIT
+4 NEW FDA,ERR,FNUM,IEN,OPR,DELX,IN,OUT,CT,HIS,X
+5 SET FNUM=$PIECE(^AUTTREFT(TYPE,0),U,2)
SET OPR=1
+6 DO REFUSAL^BEHOENP1(FNUM,CODE,VIEN,.IEN)
+7 IF "@"[RSN
IF 'IEN
QUIT
SET TYPE="@"
SET OPR=2
SET DELX=$GET(^AUPNPREF(IEN,0))
+8 IF 'IEN
SET IEN="+1"
SET OPR=0
+9 SET FDA=$NAME(FDA(9000022,IEN_","))
+10 SET @FDA@(.01)=TYPE
+11 SET @FDA@(.02)=DFN
+12 SET @FDA@(.03)=^AUPNVSIT(VIEN,0)\1
+13 SET @FDA@(.04)=$PIECE(VAL,U,4)
+14 SET @FDA@(.05)=FNUM
+15 SET @FDA@(.06)=CODE
+16 SET @FDA@(.08)=$$NOW^XLFDT
+17 ;IHS/MSC/MGH Patch 13 Added for reason
+18 IF $LENGTH(RSN)>0
Begin DoDot:1
+19 SET CT=$$GET1^DIQ(9999999.102,RSN,.01)
+20 SET HIS=$$GET1^DIQ(9999999.102,RSN,.04,"I")
+21 SET @FDA@(.07)=HIS
+22 KILL ARR
+23 IF CT'=""
Begin DoDot:2
+24 SET IN=CT_"^^^1^"
+25 SET OUT="ARR"
+26 SET @FDA@(1.01)=CT
+27 SET X=$$CNCLKP^BSTSAPI(.OUT,.IN)
+28 IF X>0
Begin DoDot:3
+29 SET @FDA@(1.02)=ARR(1,"PRE","DSC")
End DoDot:3
End DoDot:2
End DoDot:1
+30 ;END patch 13 mod
+31 IF $EXTRACT(IEN)="+"
Begin DoDot:1
+32 SET @FDA@(1216)=$$NOW^XLFDT
+33 SET @FDA@(1217)=DUZ
End DoDot:1
+34 SET @FDA@(1218)=$$NOW^XLFDT
+35 SET @FDA@(1219)=DUZ
+36 DO UPDATE^DIE("","FDA","IEN","ERR")
+37 IF $DATA(ERR("DIERR"))
QUIT
+38 IF 'OPR
SET IEN=IEN(1)
+39 DO REFEVT(IEN,OPR,.DELX)
+40 QUIT
+41 ; Broadcast a refusal event
REFEVT(IEN,OPR,X) ;EP
+1 NEW DFN,TYPE
+2 IF '$DATA(X)
SET X=$GET(^AUPNPREF(IEN,0))
+3 SET DFN=$PIECE(X,U,2)
+4 IF 'DFN
QUIT
+5 SET TYPE=$PIECE($GET(^AUTTREFT(+X,0)),U)
+6 DO BRDCAST^CIANBEVT("REFUSAL."_DFN_"."_TYPE,IEN_U_$GET(CIA("UID"))_U_OPR)
+7 QUIT
+8 ; Lookup and optionally add narrative
+9 ; Returns pointer to PROVIDER NARRATIVE file
NARR(DESCT) ;
+1 NEW IEN,TRC,NARR,FDA,TXT
+2 IF '$LENGTH(DESCT)
QUIT ""
+3 ;S DESCT=$$STRPNAR(DESCT) ;P14
+4 SET TXT=$EXTRACT(DESCT,1,160)
SET TRC=$EXTRACT(DESCT,1,30)
+5 ;S TXT="|"_DESCT
+6 FOR IEN=0:0
SET IEN=$ORDER(^AUTNPOV("B",TRC,IEN))
IF 'IEN
QUIT
IF $PIECE($GET(^AUTNPOV(IEN,0)),U)=TXT
QUIT
+7 IF IEN
QUIT IEN
+8 SET FDA(9999999.27,"+1,",.01)=TXT
+9 DO UPDATE^DIE("E","FDA","IEN","ERR")
+10 QUIT $GET(IEN(1))
UPPER(X) ; Convert lower case X to UPPER CASE
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 ; Lookup Education Topic and return pointer if text passed
PEDTOPIC(TOP) ;EP
+1 IF TOP=+TOP
QUIT TOP
+2 NEW TIEN
+3 SET TIEN=$$FIND1^DIC(9001002.5,,"X",TOP)
+4 QUIT $SELECT(TIEN>0:+TIEN,1:"")
+5 ;Strip out leading punctuation characters from Provider Narrative text
STRPNAR(NARR) ;EP-
+1 NEW LP,C,FLG
+2 FOR LP=1:1:$LENGTH(NARR)
SET C=$EXTRACT(NARR,LP)
IF '(C?1P)
SET FLG=1
QUIT
+3 QUIT $SELECT($GET(FLG):$EXTRACT(NARR,LP,$LENGTH(NARR)),1:"")
AICD() ;EP
+1 QUIT $SELECT($$VERSION^XPDUTL("AICD")<"4.0":0,1:1)
