BGOVPED ; IHS/BAO/TMD - Patient Education ;16-Jul-2014 09:35;DU
;;1.1;BGO COMPONENTS;**1,2,3,5,6,8,11,12,13,22**;Mar 20, 2007;Build 2
;---------------------------------------------
; Get patient ed records for a patient
; INP = Patient IEN ^ Visit IEN (optional)
; .RET returned as list of records in format:
; Topic Name [1] ^ Visit Date [2] ^ Level [3] ^ Provider Name [4] ^ Group/Individual [5] ^ Length [6] ^
; CPT [7] ^ Comment [8] ^ Topic Category [9] ^ Behavior [10] ^ Objective Met [11] ^ Visit Locked [12] ^
; Location Name [13] ^ VFile IEN [14] ^ Visit IEN [15] ^ Topic IEN [16] ^ Location IEN [17] ^ Provider IEN [18] ^
; Visit Category [19] ^ ICD9 text [20] ^ Comments [21] ^ ICD9 IEN [22] ^ CPT IEN [23] ^ Readiness to learn [24] ^ ICD code [25] ^ Entry date [26]
GET(RET,INP) ;EP
N BGO,CNT,REC,TOPIC,VIEN,PRV,GRP,LNGTH,ICD,ICDIEN,CPTIEN,ICDCD,EVNDT
N CPT,COMMENT,CAT,BEHAV,OBJMET,NARR,EDTIEN,LVL,VPED,DFN,VIENX
N LOCNAME,LOCIEN,VDT,VDATE,VCAT,PRVIEN,COMMENTS,MAJTOPIC,NAMEP,READY
N XREF,ICDFIELD,IN,OUT,X,SNO,TXT,TOPTYP,MAX,QFLG
S RET=$$TMPGBL^BGOUTL
S DFN=+INP
S VIENX=$P(INP,U,2)
S XREF=$$VFPTXREF^BGOUTL2
S MAX=$$GET^XPAR("ALL","BGO PAT EDU MAX ENTRIES") I MAX="" S MAX=200
S (CNT,QFLG)=0,VPED=""
F S VPED=$O(^AUPNVPED(XREF,DFN,VPED),-1) Q:VPED=""!(QFLG) D
.S REC=$G(^AUPNVPED(VPED,0))
.Q:REC=""
.I CNT>MAX S QFLG=1 Q
.S EDTIEN=$P(REC,U)
.S NAMEP=$$NEWVPED+1
.S TOPIC=$P($G(^AUTTEDT(EDTIEN,0)),U,NAMEP)
.S TOPTYP=$P($P($G(^AUTTEDT(EDTIEN,0)),U,1),"-",2)
.Q:TOPIC=""
.S MAJTOPIC=$P($G(^AUTTEDT(EDTIEN,0)),U,6)
.I MAJTOPIC'="" D
..S MAJTOPIC=$O(^AUTTEDMT("B",MAJTOPIC,0))
..S MAJTOPIC=$P($G(^AUTTEDMT(+MAJTOPIC,0)),U)
.S:$L(MAJTOPIC) TOPIC=MAJTOPIC_"-"_$S($P(TOPIC,"-",2)'="":$P(TOPIC,"-",2,4),1:TOPIC)
.S VIEN=$P(REC,U,3)
.I VIENX,VIEN'=VIENX Q
.S PRVIEN=$P(REC,U,5)
.;Patch 11 add event date
.S EVNDT=$$FMTDATE^BGOUTL($P($G(^AUPNVPED(VPED,12)),U,1))
.I EVNDT="" S EVNDT=$P($G(^AUPNVSIT(VIEN,0)),U,1)
.S PRV=$P($G(^VA(200,+PRVIEN,0)),U)
.S LVL=$$EXTERNAL^DILFD($$FNUM,.06,,$P(REC,U,6))
.S GRP=$P(REC,U,7)
.S GRP=$S(GRP="I":"Individual",GRP="G":"Group",1:"")
.S LNGTH=$P(REC,U,8)
.S CPTIEN=$P(REC,U,9)
.S:'CPTIEN CPTIEN=$P($G(^AUTTEDT(EDTIEN,0)),U,11)
.S CPT=$S(CPTIEN:$P($G(^ICPT(+CPTIEN,0)),U,2),1:"")
.S:$L(CPT) TOPIC=CPT_"-"_$P(TOPIC,"-",2)
.;Changes made to support RPMS and VistA databases
.S ICDFIELD=$$ICDF^BGOVPED ;P6
.S ICDIEN=$P(REC,U,ICDFIELD) ;P6
.S:'ICDIEN ICDIEN=$P($G(^AUTTEDT(EDTIEN,0)),U,ICDFIELD) ;P6
.;Patch 12 changed for AICD
.;S ICD=$S(ICDIEN:$P($G(^ICD9(+ICDIEN,0)),U,3),1:"")
.I $$AICD^BGOUTL2 D
..S ICD=$P($$ICDDX^ICDEX(ICDIEN,EVNDT,"","I"),U,4)
.E D
..S ICD=$S(ICDIEN:$P($G(^ICD9(+ICDIEN,0)),U,3),1:"")
.;IHS/MSC/MGH patch 8
.;IHS/MSC/MGH patch 12
.;S ICDCD=$S(ICDIEN:$P($G(^ICD9(+ICDIEN,0)),U,1),1:"")
.I $$AICD^BGOUTL2 D
..S ICDCD=$P($$ICDDX^ICDEX(ICDIEN,EVNDT,"","I"),U,2)
.E D
..S ICDCD=$P($$ICDDX^ICDCODE(ICDIEN,EVNDT),U,2)
.;end changes
.S:$L(ICD) TOPIC=ICD_"-"_$P(TOPIC,"-",2)
.;Patch 13 check for SNOMED topic
.;IHS/MSC/MGH added for patch 13, process SNOMED topics
.I $P($G(^AUTTEDT(EDTIEN,0)),U,12)'="" D
..S TXT=""
..S SNO=$P($G(^AUTTEDT(EDTIEN,0)),U,12)
..S IN=SNO_U_36_U_U_1
..S X=$$CONC^BSTSAPI(IN)
..S TXT=$P(X,U,4)
..S ICDCD=SNO
..I $L(TXT) S TOPIC=TXT_"-"_TOPTYP
.S COMMENT=$P(REC,U,11)
.S CAT=$P(REC,U,12)
.S:CAT CAT=$P($G(^APCDEDCV(CAT,0)),U)
.S BEHAV=$P(REC,U,13)
.S OBJMET=$P(REC,U,14)
.S NARR=$P($G(^AUPNVPED(VPED,11)),U)
.;IHS/MSC/MGH Added for patch 6
.S READY=$P($G(^AUPNVPED(VPED,11)),U,2)
.S:READY READY=$P($G(^AUTTRTL(READY,0)),U)
.S COMMENTS=$P($G(^AUPNVPED(VPED,811)),U)
.I $L(OBJMET) S COMMENTS=OBJMET
.I $L(COMMENTS) D
..N P,X
..S P=$S(BEHAV="GM":2,BEHAV="GNM":3,1:1)
..S X=$P(COMMENTS,"|",P)
..S:$L(X) OBJMET=X
.S BEHAV=$$EXTERNAL^DILFD($$FNUM,.13,,BEHAV)
.S LOCIEN=$P($G(^AUPNVSIT(VIEN,0)),U,6)
.S LOCNAME=$P($G(^DIC(4,+LOCIEN,0)),U)
.S:$P($G(^AUPNVSIT(VIEN,21)),U)'="" LOCNAME=$P(^(21),U)
.S VCAT=$P($G(^AUPNVSIT(VIEN,0)),U,7),VDT=+$G(^(0))
.S VDATE=$$FMTDATE^BGOUTL(VDT)
.S CNT=CNT+1
.S @RET@(CNT)=TOPIC_U_VDATE_U_LVL_U_PRV_U_GRP_U_LNGTH_U_CPT_U_COMMENT_U_CAT_U_BEHAV_U_OBJMET_U_$$ISLOCKED^BEHOENCX(VIEN)_U_LOCNAME_U_VPED_U_VIEN_U_EDTIEN_U_LOCIEN_U_PRVIEN_U_VCAT_U_ICD_U_COMMENTS_U_ICDIEN_U_CPTIEN_U_READY_U_ICDCD_U_EVNDT
Q
; Delete a patient ed entry
DEL(RET,VPED) ;EP
N X
S X=$G(^AUPNVPED(+VPED,0))
I $P(X,U,6)=5,$$REFDEL2^BGOUTL2(+$P(X,U,3),+X,"EDUCATION TOPICS")
D VFDEL^BGOUTL2(.RET,$$FNUM,VPED)
Q
; Get primary provider for patient ed entry
PRIPRV(RET,VPED) ;EP
S RET=$$PRIPRV^BGOUTL($P(^AUPNVPED(VPED,0),U,3))
Q
; Get education topics
; MODE = 0:category, 1:diagnosis, 2:non-diagnosis
; Returned as a list of records in the format:
; Name ^ Category Name ^ ICD IEN ^ ICD Name ^ Education Topic IEN ^ Type
GETTYPES(RET,MODE) ;EP
N BGO,NAME,CATNAME,ICD,ICDNAME,CATP,EDT,CNT,REC,TYPE,CAT,XX,NAMEP
N MNEXREF,ICDFIELD
S RET=$$TMPGBL^BGOUTL
S (CNT,EDT)=0
S NAMEP=$$NEWVPED+1
S MNEXREF=$E("CB",NAMEP)
S ICDFIELD=$$ICDF^BGOVPED ;P6
S XX=""
F S XX=$O(^AUTTEDT(MNEXREF,XX)),EDT=0 Q:XX="" D
.F S EDT=$O(^AUTTEDT(MNEXREF,XX,EDT)) Q:'EDT D
..S REC=$G(^AUTTEDT(EDT,0))
..Q:'$L(REC)
..Q:$P(REC,U,3)
..S CATNAME="",ICDNAME="",TYPE="E"
..S NAME=$P(REC,U,NAMEP)
..S ICD=$P(REC,U,ICDFIELD)
..;MSC/IHS/MGH Patch 12
..;I ICD S ICDNAME=$P($G(^ICD9(ICD,0)),U,3)
..I $$AICD^BGOUTL2 D
...S ICDNAME=$P($$ICDDX^ICDEX(ICD,$$NOW^XLFDT,"","I"),U,4)
..E D
...S ICDNAME=$S(ICD:$P($G(^ICD9(+ICD,0)),U,3),1:"")
..S CATP=$P(REC,U,6)
..I CATP'="" D
...I $L(CATP)>4 S CATP=$E(CATP,1,4)
...S CATP=$O(^AUTTEDMT("B",CATP,0))
...S:CATP CATNAME=$P($G(^AUTTEDMT(CATP,0)),U)
..Q:CATNAME=""
..I 'MODE,CATNAME'="" D
...Q:$D(CAT(CATNAME))
...S CAT(CATNAME)=""
...S CNT=CNT+1,@RET@(CNT)=CATNAME_U_CATNAME_"^^^^C"
..E I MODE=1 D
...S CATNAME=ICDNAME
...Q:ICDNAME=""
...Q:$D(CAT(ICDNAME))
...S CAT(ICDNAME)=""
...S CNT=CNT+1,@RET@(CNT)=ICDNAME_U_ICDNAME_"^^^^C"
..S:'$L(ICD) CNT=CNT+1,@RET@(CNT)=NAME_U_CATNAME_U_ICD_U_ICDNAME_U_EDT_U_TYPE
Q
; Returns category for an education topic
; EDT = Education topic IEN
GETNAME(RET,EDT) ;EP
N X,X0,Z
S RET=""
Q:'$G(EDT)
S X0=$G(^AUTTEDT(EDT,0))
S X=$P(X0,U,6)
I $L(X) D
.S X=$O(^AUTTEDMT("B",X,0))
.S:X RET=$P($G(^AUTTEDMT(X,0)),U)
I '$L(RET) D
.S X=$P(X0,U,4)
.;IHS/MSC/MGH Patch 12
.;S:X RET=$P($G(^ICD9(X,0)),U,3)
.I $$AICD^BGOUTL2 D
..S X=$P($$ICDDX^ICDEX(X,$$NOW^XLFDT,"","I"),U,4)
.E D
..S X=$S(X:$P($G(^ICD9(X,0)),U,3),1:"")
.S:X'="" RET=X
I '$L(RET) D
.S X=$P(X0,U,11)
.S:X RET=$P($G(^ICPT(X,0)),U,2)
;Patch 13 for SNOMED terms
I '$L(RET) D
.S SNO=$P(X0,U,12)
.S IN=SNO_U_36_U_U_1
.S Z=$$CONC^BSTSAPI(IN)
.I Z>0 S RET=$P(Z,U,4)
.;S X=$G(@OUT@(1,"PRE","TRM")) ; DKA Patch 13
.;S:X RET=X
Q
; Returns a list of education topics for PCC data entry
GETTOPIC(RET,DUMMY) ;EP
N X,CNT
S (X,CNT)=0,RET=$$TMPGBL^BGOUTL
F S X=$O(^APCDEDCV(X)) Q:'X D
.S CNT=CNT+1,@RET@(CNT)=X_U_$P(^APCDEDCV(X,0),U)
Q
; Return outcome and standard counts for an education topic
GETOS(RET,EDT) ;EP
N X,CNT,NAMEP,TOPIC,MAJTOPIC
K RET
I '$G(EDT) S RET(1)=$$ERR^BGOUTL(1008) Q
I '$D(^AUTTEDT(EDT,0)) S RET(1)=$$ERR^BGOUTL(1088) Q
S NAMEP=$$NEWVPED+1
S TOPIC=$P(^AUTTEDT(EDT,0),U,NAMEP),MAJTOPIC=$P(^(0),U,6)
S:$L(MAJTOPIC) MAJTOPIC=$O(^AUTTEDMT("B",MAJTOPIC,0)),MAJTOPIC=$P($G(^AUTTEDMT(+MAJTOPIC,0)),U)
S:$L(MAJTOPIC) TOPIC=MAJTOPIC_"-"_$S($P(TOPIC,"-",2)'="":$P(TOPIC,"-",2,4),1:TOPIC)
S CNT=0
D GO1(TOPIC),GO2(1),GO2(2)
Q
; Add to output array
GO1(X) S CNT=CNT+1,RET(CNT)=X
Q
; Add outcome/standard text to output array
GO2(N) N X,Y,L
S X=0,L=$P("OUTCOME^STANDARD",U,N)
F S X=$O(^AUTTEDT(EDT,N,X)) Q:'X S Y=$G(^(X,0)) D
.I $L(L) D
..D GO1("")
..D:$E(Y,1,$L(L))'=L GO1(L_":")
..S L=""
.D GO1(Y)
Q
; Sets/returns diagnostic-based topic/education
; INP = ICD9 IEN ^ EDC IEN
SETDXTOP(RET,INP,ICDFLG) ;EP
S RET=$$SETTOP($P(INP,U),$P(INP,U,2),$G(ICDFLG))
Q
; Sets/returns procedure-based topic/education
; INP = CPT4 IEN ^ EDC IEN
SETPXTOP(RET,INP) ;EP
S RET=$$SETTOP($P(INP,U),$P(INP,U,2),0)
Q
;Patch 13 Set/returns SNOMED topic/education
SETSNTOP(RET,INP) ;EP
S RET=$$SETTOP($P(INP,U),$P(INP,U,2),2)
Q
; Sets/Returns DX/PX-topic education
SETTOP(CODEIEN,EDCVIEN,ICDFLG) ;
N CODE,CODENM,TOPIC,TOP,NAME,MNEM,F01,RET,ICDFLD
Q:'EDCVIEN ""
S ICDFLG=$G(ICDFLG)
S TOPIC=$P($G(^APCDEDCV(EDCVIEN,0)),U),TOP=$P($G(^(0)),U,2)
Q:'$L(TOPIC)!'$L(TOP) ""
;IHS/MSC/MGH Patch 12
;I ICDFLG S CODE=$P($G(^ICD9(CODEIEN,0)),U),CODENM=$P($G(^(0)),U,3)
I ICDFLG=1 D
.I $$AICD^BGOUTL2 D
..S Y=$$ICDDX^ICDEX(CODEIEN,$$NOW^XLFDT,"","I")
..S CODE=$P(Y,U,2),CODENM=$P(Y,U,4)
.E D
..S Y=$$ICDDX^ICDCODE(CODEIEN,$$NOW^XLFDT)
..S CODE=$P(Y,U,2),CODENM=$P(Y,U,4)
;Patch 13 SNOMED codes
E D
.I ICDFLG=2 D
..S CODENM="",CODE=""
..S IN=CODEIEN_U_U_U_1
..S X=$$CONC^BSTSAPI(IN)
..I $P(X,U,1)="" D
...S IN=CODEIEN_U_U_1
...S X=$$DESC^BSTSAPI(IN)
...I +$P(X,U,1) S CODE=$P(X,U,1),CODENM=""
..E S CODE=CODEIEN,CODENM=""
.E S CODE=$P($G(^ICPT(CODEIEN,0)),U),CODENM=$P($G(^(0)),U,2)
;IHS/MSC/MGH changed to store code
S:'$L(CODENM) CODENM=CODEIEN,CODEIEN="" ; Uncoded entry
S NAME=CODE_"-"_TOPIC,MNEM=CODE_"-"_TOP
S F01=$S($$NEWVPED:MNEM,1:NAME)
S ICDFLD=$$ICDFNUM^BGOVPED ;Patch 8
S RET=$O(^AUTTEDT("B",F01,0))_U_F01
I 'RET D
.N FDA,IEN
.S FDA=$NA(FDA(9999999.09,"+1,"))
.S @FDA@(.01)=F01
.S @FDA@(1)=$S($$NEWVPED:NAME,1:MNEM)
.;Patch 11
.I ICDFLG=1 D
..S @FDA@(ICDFLD)=CODEIEN ;Patch 8 change
.I ICDFLG=2 D
..S @FDA@(.12)=CODE
.E S @FDA@(.11)=CODEIEN
.S RET=$$UPDATE^BGOUTL(.FDA,,.IEN)
.S:'RET RET=IEN(1)_U_F01
Q RET
; Set patient ed entry
; INP = VFile IEN [1] ^ Topic [2] ^ Patient IEN [3] ^ Visit IEN [4] ^ Provider IEN [5] ^
; Level Understanding [6] ^ Individual/Group [7] ^ Length [8] ^ CPT [9] ^ Comment [10] ^
; Behavior Code [11] ^ Objectives [12] ^ Event Date [13] ^ Location IEN [14] ^
; Other Location [15] ^ Historical [16] ^ Readiness [17] ^ Allow Dups [18] ^ Problem IEN[19]
SET(RET,INP) ;EP
N VIEN,FDA,VCAT,APCDALVR,DFN,CPT,VFIEN,TYPE,LVL,PRV,GRP,LEN,COMMENT,BEHAV,OBJMET,SNO,PROB
N EVNTDT,LOCIEN,OUTLOC,HIST,DX,OLDLVL,READY,FNUM,VFNEW,DUPS,ICDFIELD,READY,ICDFNUM,CT
S RET="",FNUM=$$FNUM
S ICDFIELD=$$ICDF^BGOVPED ;P6
S VFIEN=+INP
S VFNEW='VFIEN
S TYPE=+$P(INP,U,2)
I '$D(^AUTTEDT(TYPE,0)) S RET=$$ERR^BGOUTL(1088) Q
S DFN=+$P(INP,U,3)
I '$D(^AUPNPAT(DFN,0)) S RET=$$ERR^BGOUTL(1001) Q
S VIEN=+$P(INP,U,4)
S PRV=$P(INP,U,5)
S LVL=$P(INP,U,6)
S GRP=$P(INP,U,7)
S LEN=$P(INP,U,8)
S CPT=$P(INP,U,9)
S COMMENT=$P(INP,U,10)
S BEHAV=$P(INP,U,11)
S OBJMET=$P(INP,U,12)
S EVNTDT=$$CVTDATE^BGOUTL($P(INP,U,13))
S LOCIEN=$P(INP,U,14)
S OUTLOC=$P(INP,U,15)
S HIST=$P(INP,U,16)
S READY=$P(INP,U,17)
S DUPS=$P(INP,U,18)
S PROB=$P(INP,U,19)
S:'$L(DUPS) DUPS=1
S VCAT=$P($G(^AUPNVSIT(VIEN,0)),U,7)
S:VCAT="E" HIST=1
I 'VIEN,'HIST S RET=$$ERR^BGOUTL(1002) Q
I HIST D Q:RET<0
.S RET=$$MAKEHIST^BGOUTL(DFN,EVNTDT,$S($L(OUTLOC):OUTLOC,1:LOCIEN),VIEN)
.S:RET>0 VIEN=RET
S RET=$$CHKVISIT^BGOUTL(VIEN,DFN)
Q:RET
S DX=$P(^AUTTEDT(TYPE,0),U,ICDFIELD) ;P6
S SNO=$P(^AUTTEDT(TYPE,0),U,12) ;P13 snomed field
I 'VFIEN D Q:'VFIEN
.D VFNEW^BGOUTL2(.RET,FNUM,TYPE,VIEN,$S('DUPS:"Education",1:""))
.S:RET>0 VFIEN=RET,RET=""
.S OLDLVL=""
E S OLDLVL=$P($G(^AUPNVPED(VFIEN,0)),U,6)
S FDA=$NA(FDA(FNUM,VFIEN_","))
S @FDA@(.01)="`"_TYPE
S ICDFNUM=$$ICDFNUM^BGOVPED
S @FDA@(.04)=$S(DX:"`"_DX,1:"") ;Patch 8 change
S @FDA@(.05)=$S(PRV:"`"_PRV,1:"")
S @FDA@(.06)=LVL
S @FDA@(.07)=GRP
S @FDA@(.08)=LEN
S @FDA@(.09)=$S(CPT:"`"_CPT,1:"")
S @FDA@(.11)=COMMENT
S @FDA@(.13)=BEHAV
S @FDA@(1204)="`"_DUZ
S @FDA@(1201)="N"
S @FDA@(1301)=SNO
I PROB'="" S @FDA@(1103)="`"_PROB ;p13 edu may be connected to problem
;Patch 11 Set date entered
I VFNEW D
.S @FDA@(1216)="N"
.S @FDA@(1217)="`"_DUZ
;Patch 11 Set last modified
S @FDA@(1218)="N"
S @FDA@(1219)="`"_DUZ
S @FDA@(1102)=READY ;IHS/MSC/MGH patch 6
I $L(OBJMET) D
.N P,COMMENTS
.S COMMENTS=$P($G(^AUPNVPED(VFIEN,811)),U)
.S P=$S(BEHAV="GM":2,BEHAV="GNM":3,1:1)
.S:P>1 $P(COMMENTS,"|",5-P)=""
.S $P(COMMENTS,"|",P)=$TR(OBJMET,"|")
.I $L(OBJMET) S COMMENTS=OBJMET
.;S @FDA@(81101)=COMMENTS
.S @FDA@(.14)=COMMENTS
S RET=$$UPDATE^BGOUTL(.FDA,"E")
I RET,VFNEW,$$DELETE^BGOUTL(FNUM,VFIEN)
I 'RET,LVL=5,OLDLVL'=LVL D
.S CT=443390004
.S RET=$$REFSET^BGOUTL2(VIEN,TYPE,"EDUCATION TOPICS","R",COMMENT,"",CT)
I 'RET,OLDLVL=5,OLDLVL'=LVL S RET=$$REFDEL2^BGOUTL2(VIEN,TYPE,"EDUCATION TOPICS")
D:'RET VFEVT^BGOUTL2(FNUM,VFIEN,'VFNEW)
S:'RET RET=VFIEN
Q
; Returns true if new V Patient Ed format
NEWVPED() Q $$FLDNUM^DILFD(9999999.09,"NAME")'=.01
; Return V File #
FNUM() Q 9000010.16
ICDF() Q $S($G(DUZ("AG"))="I":"4",1:"10")
ICDFNUM() Q $S($G(DUZ("AG"))="I":".04",1:".1")
BGOVPED ; IHS/BAO/TMD - Patient Education ;16-Jul-2014 09:35;DU
+1 ;;1.1;BGO COMPONENTS;**1,2,3,5,6,8,11,12,13,22**;Mar 20, 2007;Build 2
+2 ;---------------------------------------------
+3 ; Get patient ed records for a patient
+4 ; INP = Patient IEN ^ Visit IEN (optional)
+5 ; .RET returned as list of records in format:
+6 ; Topic Name [1] ^ Visit Date [2] ^ Level [3] ^ Provider Name [4] ^ Group/Individual [5] ^ Length [6] ^
+7 ; CPT [7] ^ Comment [8] ^ Topic Category [9] ^ Behavior [10] ^ Objective Met [11] ^ Visit Locked [12] ^
+8 ; Location Name [13] ^ VFile IEN [14] ^ Visit IEN [15] ^ Topic IEN [16] ^ Location IEN [17] ^ Provider IEN [18] ^
+9 ; Visit Category [19] ^ ICD9 text [20] ^ Comments [21] ^ ICD9 IEN [22] ^ CPT IEN [23] ^ Readiness to learn [24] ^ ICD code [25] ^ Entry date [26]
GET(RET,INP) ;EP
+1 NEW BGO,CNT,REC,TOPIC,VIEN,PRV,GRP,LNGTH,ICD,ICDIEN,CPTIEN,ICDCD,EVNDT
+2 NEW CPT,COMMENT,CAT,BEHAV,OBJMET,NARR,EDTIEN,LVL,VPED,DFN,VIENX
+3 NEW LOCNAME,LOCIEN,VDT,VDATE,VCAT,PRVIEN,COMMENTS,MAJTOPIC,NAMEP,READY
+4 NEW XREF,ICDFIELD,IN,OUT,X,SNO,TXT,TOPTYP,MAX,QFLG
+5 SET RET=$$TMPGBL^BGOUTL
+6 SET DFN=+INP
+7 SET VIENX=$PIECE(INP,U,2)
+8 SET XREF=$$VFPTXREF^BGOUTL2
+9 SET MAX=$$GET^XPAR("ALL","BGO PAT EDU MAX ENTRIES")
IF MAX=""
SET MAX=200
+10 SET (CNT,QFLG)=0
SET VPED=""
+11 FOR
SET VPED=$ORDER(^AUPNVPED(XREF,DFN,VPED),-1)
IF VPED=""!(QFLG)
QUIT
Begin DoDot:1
+12 SET REC=$GET(^AUPNVPED(VPED,0))
+13 IF REC=""
QUIT
+14 IF CNT>MAX
SET QFLG=1
QUIT
+15 SET EDTIEN=$PIECE(REC,U)
+16 SET NAMEP=$$NEWVPED+1
+17 SET TOPIC=$PIECE($GET(^AUTTEDT(EDTIEN,0)),U,NAMEP)
+18 SET TOPTYP=$PIECE($PIECE($GET(^AUTTEDT(EDTIEN,0)),U,1),"-",2)
+19 IF TOPIC=""
QUIT
+20 SET MAJTOPIC=$PIECE($GET(^AUTTEDT(EDTIEN,0)),U,6)
+21 IF MAJTOPIC'=""
Begin DoDot:2
+22 SET MAJTOPIC=$ORDER(^AUTTEDMT("B",MAJTOPIC,0))
+23 SET MAJTOPIC=$PIECE($GET(^AUTTEDMT(+MAJTOPIC,0)),U)
End DoDot:2
+24 IF $LENGTH(MAJTOPIC)
SET TOPIC=MAJTOPIC_"-"_$SELECT($PIECE(TOPIC,"-",2)'="":$PIECE(TOPIC,"-",2,4),1:TOPIC)
+25 SET VIEN=$PIECE(REC,U,3)
+26 IF VIENX
IF VIEN'=VIENX
QUIT
+27 SET PRVIEN=$PIECE(REC,U,5)
+28 ;Patch 11 add event date
+29 SET EVNDT=$$FMTDATE^BGOUTL($PIECE($GET(^AUPNVPED(VPED,12)),U,1))
+30 IF EVNDT=""
SET EVNDT=$PIECE($GET(^AUPNVSIT(VIEN,0)),U,1)
+31 SET PRV=$PIECE($GET(^VA(200,+PRVIEN,0)),U)
+32 SET LVL=$$EXTERNAL^DILFD($$FNUM,.06,,$PIECE(REC,U,6))
+33 SET GRP=$PIECE(REC,U,7)
+34 SET GRP=$SELECT(GRP="I":"Individual",GRP="G":"Group",1:"")
+35 SET LNGTH=$PIECE(REC,U,8)
+36 SET CPTIEN=$PIECE(REC,U,9)
+37 IF 'CPTIEN
SET CPTIEN=$PIECE($GET(^AUTTEDT(EDTIEN,0)),U,11)
+38 SET CPT=$SELECT(CPTIEN:$PIECE($GET(^ICPT(+CPTIEN,0)),U,2),1:"")
+39 IF $LENGTH(CPT)
SET TOPIC=CPT_"-"_$PIECE(TOPIC,"-",2)
+40 ;Changes made to support RPMS and VistA databases
+41 ;P6
SET ICDFIELD=$$ICDF^BGOVPED
+42 ;P6
SET ICDIEN=$PIECE(REC,U,ICDFIELD)
+43 ;P6
IF 'ICDIEN
SET ICDIEN=$PIECE($GET(^AUTTEDT(EDTIEN,0)),U,ICDFIELD)
+44 ;Patch 12 changed for AICD
+45 ;S ICD=$S(ICDIEN:$P($G(^ICD9(+ICDIEN,0)),U,3),1:"")
+46 IF $$AICD^BGOUTL2
Begin DoDot:2
+47 SET ICD=$PIECE($$ICDDX^ICDEX(ICDIEN,EVNDT,"","I"),U,4)
End DoDot:2
+48 IF '$TEST
Begin DoDot:2
+49 SET ICD=$SELECT(ICDIEN:$PIECE($GET(^ICD9(+ICDIEN,0)),U,3),1:"")
End DoDot:2
+50 ;IHS/MSC/MGH patch 8
+51 ;IHS/MSC/MGH patch 12
+52 ;S ICDCD=$S(ICDIEN:$P($G(^ICD9(+ICDIEN,0)),U,1),1:"")
+53 IF $$AICD^BGOUTL2
Begin DoDot:2
+54 SET ICDCD=$PIECE($$ICDDX^ICDEX(ICDIEN,EVNDT,"","I"),U,2)
End DoDot:2
+55 IF '$TEST
Begin DoDot:2
+56 SET ICDCD=$PIECE($$ICDDX^ICDCODE(ICDIEN,EVNDT),U,2)
End DoDot:2
+57 ;end changes
+58 IF $LENGTH(ICD)
SET TOPIC=ICD_"-"_$PIECE(TOPIC,"-",2)
+59 ;Patch 13 check for SNOMED topic
+60 ;IHS/MSC/MGH added for patch 13, process SNOMED topics
+61 IF $PIECE($GET(^AUTTEDT(EDTIEN,0)),U,12)'=""
Begin DoDot:2
+62 SET TXT=""
+63 SET SNO=$PIECE($GET(^AUTTEDT(EDTIEN,0)),U,12)
+64 SET IN=SNO_U_36_U_U_1
+65 SET X=$$CONC^BSTSAPI(IN)
+66 SET TXT=$PIECE(X,U,4)
+67 SET ICDCD=SNO
+68 IF $LENGTH(TXT)
SET TOPIC=TXT_"-"_TOPTYP
End DoDot:2
+69 SET COMMENT=$PIECE(REC,U,11)
+70 SET CAT=$PIECE(REC,U,12)
+71 IF CAT
SET CAT=$PIECE($GET(^APCDEDCV(CAT,0)),U)
+72 SET BEHAV=$PIECE(REC,U,13)
+73 SET OBJMET=$PIECE(REC,U,14)
+74 SET NARR=$PIECE($GET(^AUPNVPED(VPED,11)),U)
+75 ;IHS/MSC/MGH Added for patch 6
+76 SET READY=$PIECE($GET(^AUPNVPED(VPED,11)),U,2)
+77 IF READY
SET READY=$PIECE($GET(^AUTTRTL(READY,0)),U)
+78 SET COMMENTS=$PIECE($GET(^AUPNVPED(VPED,811)),U)
+79 IF $LENGTH(OBJMET)
SET COMMENTS=OBJMET
+80 IF $LENGTH(COMMENTS)
Begin DoDot:2
+81 NEW P,X
+82 SET P=$SELECT(BEHAV="GM":2,BEHAV="GNM":3,1:1)
+83 SET X=$PIECE(COMMENTS,"|",P)
+84 IF $LENGTH(X)
SET OBJMET=X
End DoDot:2
+85 SET BEHAV=$$EXTERNAL^DILFD($$FNUM,.13,,BEHAV)
+86 SET LOCIEN=$PIECE($GET(^AUPNVSIT(VIEN,0)),U,6)
+87 SET LOCNAME=$PIECE($GET(^DIC(4,+LOCIEN,0)),U)
+88 IF $PIECE($GET(^AUPNVSIT(VIEN,21)),U)'=""
SET LOCNAME=$PIECE(^(21),U)
+89 SET VCAT=$PIECE($GET(^AUPNVSIT(VIEN,0)),U,7)
SET VDT=+$GET(^(0))
+90 SET VDATE=$$FMTDATE^BGOUTL(VDT)
+91 SET CNT=CNT+1
+92 SET @RET@(CNT)=TOPIC_U_VDATE_U_LVL_U_PRV_U_GRP_U_LNGTH_U_CPT_U_COMMENT_U_CAT_U_BEHAV_U_OBJMET_U_$$ISLOCKED^BEHOENCX(VIEN)_U_LOCNAME_U_VPED_U_VIEN_U_EDTIEN_U_LOCIEN_U_PRVIEN_U_VCAT_U_ICD_U_COMMENTS_U_ICDIEN_U_CPTIEN_U_READY_U_ICDCD_U_EVN
DT
End DoDot:1
+93 QUIT
+94 ; Delete a patient ed entry
DEL(RET,VPED) ;EP
+1 NEW X
+2 SET X=$GET(^AUPNVPED(+VPED,0))
+3 IF $PIECE(X,U,6)=5
IF $$REFDEL2^BGOUTL2(+$PIECE(X,U,3),+X,"EDUCATION TOPICS")
+4 DO VFDEL^BGOUTL2(.RET,$$FNUM,VPED)
+5 QUIT
+6 ; Get primary provider for patient ed entry
PRIPRV(RET,VPED) ;EP
+1 SET RET=$$PRIPRV^BGOUTL($PIECE(^AUPNVPED(VPED,0),U,3))
+2 QUIT
+3 ; Get education topics
+4 ; MODE = 0:category, 1:diagnosis, 2:non-diagnosis
+5 ; Returned as a list of records in the format:
+6 ; Name ^ Category Name ^ ICD IEN ^ ICD Name ^ Education Topic IEN ^ Type
GETTYPES(RET,MODE) ;EP
+1 NEW BGO,NAME,CATNAME,ICD,ICDNAME,CATP,EDT,CNT,REC,TYPE,CAT,XX,NAMEP
+2 NEW MNEXREF,ICDFIELD
+3 SET RET=$$TMPGBL^BGOUTL
+4 SET (CNT,EDT)=0
+5 SET NAMEP=$$NEWVPED+1
+6 SET MNEXREF=$EXTRACT("CB",NAMEP)
+7 ;P6
SET ICDFIELD=$$ICDF^BGOVPED
+8 SET XX=""
+9 FOR
SET XX=$ORDER(^AUTTEDT(MNEXREF,XX))
SET EDT=0
IF XX=""
QUIT
Begin DoDot:1
+10 FOR
SET EDT=$ORDER(^AUTTEDT(MNEXREF,XX,EDT))
IF 'EDT
QUIT
Begin DoDot:2
+11 SET REC=$GET(^AUTTEDT(EDT,0))
+12 IF '$LENGTH(REC)
QUIT
+13 IF $PIECE(REC,U,3)
QUIT
+14 SET CATNAME=""
SET ICDNAME=""
SET TYPE="E"
+15 SET NAME=$PIECE(REC,U,NAMEP)
+16 SET ICD=$PIECE(REC,U,ICDFIELD)
+17 ;MSC/IHS/MGH Patch 12
+18 ;I ICD S ICDNAME=$P($G(^ICD9(ICD,0)),U,3)
+19 IF $$AICD^BGOUTL2
Begin DoDot:3
+20 SET ICDNAME=$PIECE($$ICDDX^ICDEX(ICD,$$NOW^XLFDT,"","I"),U,4)
End DoDot:3
+21 IF '$TEST
Begin DoDot:3
+22 SET ICDNAME=$SELECT(ICD:$PIECE($GET(^ICD9(+ICD,0)),U,3),1:"")
End DoDot:3
+23 SET CATP=$PIECE(REC,U,6)
+24 IF CATP'=""
Begin DoDot:3
+25 IF $LENGTH(CATP)>4
SET CATP=$EXTRACT(CATP,1,4)
+26 SET CATP=$ORDER(^AUTTEDMT("B",CATP,0))
+27 IF CATP
SET CATNAME=$PIECE($GET(^AUTTEDMT(CATP,0)),U)
End DoDot:3
+28 IF CATNAME=""
QUIT
+29 IF 'MODE
IF CATNAME'=""
Begin DoDot:3
+30 IF $DATA(CAT(CATNAME))
QUIT
+31 SET CAT(CATNAME)=""
+32 SET CNT=CNT+1
SET @RET@(CNT)=CATNAME_U_CATNAME_"^^^^C"
End DoDot:3
+33 IF '$TEST
IF MODE=1
Begin DoDot:3
+34 SET CATNAME=ICDNAME
+35 IF ICDNAME=""
QUIT
+36 IF $DATA(CAT(ICDNAME))
QUIT
+37 SET CAT(ICDNAME)=""
+38 SET CNT=CNT+1
SET @RET@(CNT)=ICDNAME_U_ICDNAME_"^^^^C"
End DoDot:3
+39 IF '$LENGTH(ICD)
SET CNT=CNT+1
SET @RET@(CNT)=NAME_U_CATNAME_U_ICD_U_ICDNAME_U_EDT_U_TYPE
End DoDot:2
End DoDot:1
+40 QUIT
+41 ; Returns category for an education topic
+42 ; EDT = Education topic IEN
GETNAME(RET,EDT) ;EP
+1 NEW X,X0,Z
+2 SET RET=""
+3 IF '$GET(EDT)
QUIT
+4 SET X0=$GET(^AUTTEDT(EDT,0))
+5 SET X=$PIECE(X0,U,6)
+6 IF $LENGTH(X)
Begin DoDot:1
+7 SET X=$ORDER(^AUTTEDMT("B",X,0))
+8 IF X
SET RET=$PIECE($GET(^AUTTEDMT(X,0)),U)
End DoDot:1
+9 IF '$LENGTH(RET)
Begin DoDot:1
+10 SET X=$PIECE(X0,U,4)
+11 ;IHS/MSC/MGH Patch 12
+12 ;S:X RET=$P($G(^ICD9(X,0)),U,3)
+13 IF $$AICD^BGOUTL2
Begin DoDot:2
+14 SET X=$PIECE($$ICDDX^ICDEX(X,$$NOW^XLFDT,"","I"),U,4)
End DoDot:2
+15 IF '$TEST
Begin DoDot:2
+16 SET X=$SELECT(X:$PIECE($GET(^ICD9(X,0)),U,3),1:"")
End DoDot:2
+17 IF X'=""
SET RET=X
End DoDot:1
+18 IF '$LENGTH(RET)
Begin DoDot:1
+19 SET X=$PIECE(X0,U,11)
+20 IF X
SET RET=$PIECE($GET(^ICPT(X,0)),U,2)
End DoDot:1
+21 ;Patch 13 for SNOMED terms
+22 IF '$LENGTH(RET)
Begin DoDot:1
+23 SET SNO=$PIECE(X0,U,12)
+24 SET IN=SNO_U_36_U_U_1
+25 SET Z=$$CONC^BSTSAPI(IN)
+26 IF Z>0
SET RET=$PIECE(Z,U,4)
+27 ;S X=$G(@OUT@(1,"PRE","TRM")) ; DKA Patch 13
+28 ;S:X RET=X
End DoDot:1
+29 QUIT
+30 ; Returns a list of education topics for PCC data entry
GETTOPIC(RET,DUMMY) ;EP
+1 NEW X,CNT
+2 SET (X,CNT)=0
SET RET=$$TMPGBL^BGOUTL
+3 FOR
SET X=$ORDER(^APCDEDCV(X))
IF 'X
QUIT
Begin DoDot:1
+4 SET CNT=CNT+1
SET @RET@(CNT)=X_U_$PIECE(^APCDEDCV(X,0),U)
End DoDot:1
+5 QUIT
+6 ; Return outcome and standard counts for an education topic
GETOS(RET,EDT) ;EP
+1 NEW X,CNT,NAMEP,TOPIC,MAJTOPIC
+2 KILL RET
+3 IF '$GET(EDT)
SET RET(1)=$$ERR^BGOUTL(1008)
QUIT
+4 IF '$DATA(^AUTTEDT(EDT,0))
SET RET(1)=$$ERR^BGOUTL(1088)
QUIT
+5 SET NAMEP=$$NEWVPED+1
+6 SET TOPIC=$PIECE(^AUTTEDT(EDT,0),U,NAMEP)
SET MAJTOPIC=$PIECE(^(0),U,6)
+7 IF $LENGTH(MAJTOPIC)
SET MAJTOPIC=$ORDER(^AUTTEDMT("B",MAJTOPIC,0))
SET MAJTOPIC=$PIECE($GET(^AUTTEDMT(+MAJTOPIC,0)),U)
+8 IF $LENGTH(MAJTOPIC)
SET TOPIC=MAJTOPIC_"-"_$SELECT($PIECE(TOPIC,"-",2)'="":$PIECE(TOPIC,"-",2,4),1:TOPIC)
+9 SET CNT=0
+10 DO GO1(TOPIC)
DO GO2(1)
DO GO2(2)
+11 QUIT
+12 ; Add to output array
GO1(X) SET CNT=CNT+1
SET RET(CNT)=X
+1 QUIT
+2 ; Add outcome/standard text to output array
GO2(N) NEW X,Y,L
+1 SET X=0
SET L=$PIECE("OUTCOME^STANDARD",U,N)
+2 FOR
SET X=$ORDER(^AUTTEDT(EDT,N,X))
IF 'X
QUIT
SET Y=$GET(^(X,0))
Begin DoDot:1
+3 IF $LENGTH(L)
Begin DoDot:2
+4 DO GO1("")
+5 IF $EXTRACT(Y,1,$LENGTH(L))'=L
DO GO1(L_":")
+6 SET L=""
End DoDot:2
+7 DO GO1(Y)
End DoDot:1
+8 QUIT
+9 ; Sets/returns diagnostic-based topic/education
+10 ; INP = ICD9 IEN ^ EDC IEN
SETDXTOP(RET,INP,ICDFLG) ;EP
+1 SET RET=$$SETTOP($PIECE(INP,U),$PIECE(INP,U,2),$GET(ICDFLG))
+2 QUIT
+3 ; Sets/returns procedure-based topic/education
+4 ; INP = CPT4 IEN ^ EDC IEN
SETPXTOP(RET,INP) ;EP
+1 SET RET=$$SETTOP($PIECE(INP,U),$PIECE(INP,U,2),0)
+2 QUIT
+3 ;Patch 13 Set/returns SNOMED topic/education
SETSNTOP(RET,INP) ;EP
+1 SET RET=$$SETTOP($PIECE(INP,U),$PIECE(INP,U,2),2)
+2 QUIT
+3 ; Sets/Returns DX/PX-topic education
SETTOP(CODEIEN,EDCVIEN,ICDFLG) ;
+1 NEW CODE,CODENM,TOPIC,TOP,NAME,MNEM,F01,RET,ICDFLD
+2 IF 'EDCVIEN
QUIT ""
+3 SET ICDFLG=$GET(ICDFLG)
+4 SET TOPIC=$PIECE($GET(^APCDEDCV(EDCVIEN,0)),U)
SET TOP=$PIECE($GET(^(0)),U,2)
+5 IF '$LENGTH(TOPIC)!'$LENGTH(TOP)
QUIT ""
+6 ;IHS/MSC/MGH Patch 12
+7 ;I ICDFLG S CODE=$P($G(^ICD9(CODEIEN,0)),U),CODENM=$P($G(^(0)),U,3)
+8 IF ICDFLG=1
Begin DoDot:1
+9 IF $$AICD^BGOUTL2
Begin DoDot:2
+10 SET Y=$$ICDDX^ICDEX(CODEIEN,$$NOW^XLFDT,"","I")
+11 SET CODE=$PIECE(Y,U,2)
SET CODENM=$PIECE(Y,U,4)
End DoDot:2
+12 IF '$TEST
Begin DoDot:2
+13 SET Y=$$ICDDX^ICDCODE(CODEIEN,$$NOW^XLFDT)
+14 SET CODE=$PIECE(Y,U,2)
SET CODENM=$PIECE(Y,U,4)
End DoDot:2
End DoDot:1
+15 ;Patch 13 SNOMED codes
+16 IF '$TEST
Begin DoDot:1
+17 IF ICDFLG=2
Begin DoDot:2
+18 SET CODENM=""
SET CODE=""
+19 SET IN=CODEIEN_U_U_U_1
+20 SET X=$$CONC^BSTSAPI(IN)
+21 IF $PIECE(X,U,1)=""
Begin DoDot:3
+22 SET IN=CODEIEN_U_U_1
+23 SET X=$$DESC^BSTSAPI(IN)
+24 IF +$PIECE(X,U,1)
SET CODE=$PIECE(X,U,1)
SET CODENM=""
End DoDot:3
+25 IF '$TEST
SET CODE=CODEIEN
SET CODENM=""
End DoDot:2
+26 IF '$TEST
SET CODE=$PIECE($GET(^ICPT(CODEIEN,0)),U)
SET CODENM=$PIECE($GET(^(0)),U,2)
End DoDot:1
+27 ;IHS/MSC/MGH changed to store code
+28 ; Uncoded entry
IF '$LENGTH(CODENM)
SET CODENM=CODEIEN
SET CODEIEN=""
+29 SET NAME=CODE_"-"_TOPIC
SET MNEM=CODE_"-"_TOP
+30 SET F01=$SELECT($$NEWVPED:MNEM,1:NAME)
+31 ;Patch 8
SET ICDFLD=$$ICDFNUM^BGOVPED
+32 SET RET=$ORDER(^AUTTEDT("B",F01,0))_U_F01
+33 IF 'RET
Begin DoDot:1
+34 NEW FDA,IEN
+35 SET FDA=$NAME(FDA(9999999.09,"+1,"))
+36 SET @FDA@(.01)=F01
+37 SET @FDA@(1)=$SELECT($$NEWVPED:NAME,1:MNEM)
+38 ;Patch 11
+39 IF ICDFLG=1
Begin DoDot:2
+40 ;Patch 8 change
SET @FDA@(ICDFLD)=CODEIEN
End DoDot:2
+41 IF ICDFLG=2
Begin DoDot:2
+42 SET @FDA@(.12)=CODE
End DoDot:2
+43 IF '$TEST
SET @FDA@(.11)=CODEIEN
+44 SET RET=$$UPDATE^BGOUTL(.FDA,,.IEN)
+45 IF 'RET
SET RET=IEN(1)_U_F01
End DoDot:1
+46 QUIT RET
+47 ; Set patient ed entry
+48 ; INP = VFile IEN [1] ^ Topic [2] ^ Patient IEN [3] ^ Visit IEN [4] ^ Provider IEN [5] ^
+49 ; Level Understanding [6] ^ Individual/Group [7] ^ Length [8] ^ CPT [9] ^ Comment [10] ^
+50 ; Behavior Code [11] ^ Objectives [12] ^ Event Date [13] ^ Location IEN [14] ^
+51 ; Other Location [15] ^ Historical [16] ^ Readiness [17] ^ Allow Dups [18] ^ Problem IEN[19]
SET(RET,INP) ;EP
+1 NEW VIEN,FDA,VCAT,APCDALVR,DFN,CPT,VFIEN,TYPE,LVL,PRV,GRP,LEN,COMMENT,BEHAV,OBJMET,SNO,PROB
+2 NEW EVNTDT,LOCIEN,OUTLOC,HIST,DX,OLDLVL,READY,FNUM,VFNEW,DUPS,ICDFIELD,READY,ICDFNUM,CT
+3 SET RET=""
SET FNUM=$$FNUM
+4 ;P6
SET ICDFIELD=$$ICDF^BGOVPED
+5 SET VFIEN=+INP
+6 SET VFNEW='VFIEN
+7 SET TYPE=+$PIECE(INP,U,2)
+8 IF '$DATA(^AUTTEDT(TYPE,0))
SET RET=$$ERR^BGOUTL(1088)
QUIT
+9 SET DFN=+$PIECE(INP,U,3)
+10 IF '$DATA(^AUPNPAT(DFN,0))
SET RET=$$ERR^BGOUTL(1001)
QUIT
+11 SET VIEN=+$PIECE(INP,U,4)
+12 SET PRV=$PIECE(INP,U,5)
+13 SET LVL=$PIECE(INP,U,6)
+14 SET GRP=$PIECE(INP,U,7)
+15 SET LEN=$PIECE(INP,U,8)
+16 SET CPT=$PIECE(INP,U,9)
+17 SET COMMENT=$PIECE(INP,U,10)
+18 SET BEHAV=$PIECE(INP,U,11)
+19 SET OBJMET=$PIECE(INP,U,12)
+20 SET EVNTDT=$$CVTDATE^BGOUTL($PIECE(INP,U,13))
+21 SET LOCIEN=$PIECE(INP,U,14)
+22 SET OUTLOC=$PIECE(INP,U,15)
+23 SET HIST=$PIECE(INP,U,16)
+24 SET READY=$PIECE(INP,U,17)
+25 SET DUPS=$PIECE(INP,U,18)
+26 SET PROB=$PIECE(INP,U,19)
+27 IF '$LENGTH(DUPS)
SET DUPS=1
+28 SET VCAT=$PIECE($GET(^AUPNVSIT(VIEN,0)),U,7)
+29 IF VCAT="E"
SET HIST=1
+30 IF 'VIEN
IF 'HIST
SET RET=$$ERR^BGOUTL(1002)
QUIT
+31 IF HIST
Begin DoDot:1
+32 SET RET=$$MAKEHIST^BGOUTL(DFN,EVNTDT,$SELECT($LENGTH(OUTLOC):OUTLOC,1:LOCIEN),VIEN)
+33 IF RET>0
SET VIEN=RET
End DoDot:1
IF RET<0
QUIT
+34 SET RET=$$CHKVISIT^BGOUTL(VIEN,DFN)
+35 IF RET
QUIT
+36 ;P6
SET DX=$PIECE(^AUTTEDT(TYPE,0),U,ICDFIELD)
+37 ;P13 snomed field
SET SNO=$PIECE(^AUTTEDT(TYPE,0),U,12)
+38 IF 'VFIEN
Begin DoDot:1
+39 DO VFNEW^BGOUTL2(.RET,FNUM,TYPE,VIEN,$SELECT('DUPS:"Education",1:""))
+40 IF RET>0
SET VFIEN=RET
SET RET=""
+41 SET OLDLVL=""
End DoDot:1
IF 'VFIEN
QUIT
+42 IF '$TEST
SET OLDLVL=$PIECE($GET(^AUPNVPED(VFIEN,0)),U,6)
+43 SET FDA=$NAME(FDA(FNUM,VFIEN_","))
+44 SET @FDA@(.01)="`"_TYPE
+45 SET ICDFNUM=$$ICDFNUM^BGOVPED
+46 ;Patch 8 change
SET @FDA@(.04)=$SELECT(DX:"`"_DX,1:"")
+47 SET @FDA@(.05)=$SELECT(PRV:"`"_PRV,1:"")
+48 SET @FDA@(.06)=LVL
+49 SET @FDA@(.07)=GRP
+50 SET @FDA@(.08)=LEN
+51 SET @FDA@(.09)=$SELECT(CPT:"`"_CPT,1:"")
+52 SET @FDA@(.11)=COMMENT
+53 SET @FDA@(.13)=BEHAV
+54 SET @FDA@(1204)="`"_DUZ
+55 SET @FDA@(1201)="N"
+56 SET @FDA@(1301)=SNO
+57 ;p13 edu may be connected to problem
IF PROB'=""
SET @FDA@(1103)="`"_PROB
+58 ;Patch 11 Set date entered
+59 IF VFNEW
Begin DoDot:1
+60 SET @FDA@(1216)="N"
+61 SET @FDA@(1217)="`"_DUZ
End DoDot:1
+62 ;Patch 11 Set last modified
+63 SET @FDA@(1218)="N"
+64 SET @FDA@(1219)="`"_DUZ
+65 ;IHS/MSC/MGH patch 6
SET @FDA@(1102)=READY
+66 IF $LENGTH(OBJMET)
Begin DoDot:1
+67 NEW P,COMMENTS
+68 SET COMMENTS=$PIECE($GET(^AUPNVPED(VFIEN,811)),U)
+69 SET P=$SELECT(BEHAV="GM":2,BEHAV="GNM":3,1:1)
+70 IF P>1
SET $PIECE(COMMENTS,"|",5-P)=""
+71 SET $PIECE(COMMENTS,"|",P)=$TRANSLATE(OBJMET,"|")
+72 IF $LENGTH(OBJMET)
SET COMMENTS=OBJMET
+73 ;S @FDA@(81101)=COMMENTS
+74 SET @FDA@(.14)=COMMENTS
End DoDot:1
+75 SET RET=$$UPDATE^BGOUTL(.FDA,"E")
+76 IF RET
IF VFNEW
IF $$DELETE^BGOUTL(FNUM,VFIEN)
+77 IF 'RET
IF LVL=5
IF OLDLVL'=LVL
Begin DoDot:1
+78 SET CT=443390004
+79 SET RET=$$REFSET^BGOUTL2(VIEN,TYPE,"EDUCATION TOPICS","R",COMMENT,"",CT)
End DoDot:1
+80 IF 'RET
IF OLDLVL=5
IF OLDLVL'=LVL
SET RET=$$REFDEL2^BGOUTL2(VIEN,TYPE,"EDUCATION TOPICS")
+81 IF 'RET
DO VFEVT^BGOUTL2(FNUM,VFIEN,'VFNEW)
+82 IF 'RET
SET RET=VFIEN
+83 QUIT
+84 ; Returns true if new V Patient Ed format
NEWVPED() QUIT $$FLDNUM^DILFD(9999999.09,"NAME")'=.01
+1 ; Return V File #
FNUM() QUIT 9000010.16
ICDF() QUIT $SELECT($GET(DUZ("AG"))="I":"4",1:"10")
ICDFNUM() QUIT $SELECT($GET(DUZ("AG"))="I":".04",1:".1")
