BEHOENPP ;MSC/IND/MGH - Summary Report for Selected Encounter ;21-Jan-2013 17:06;DU
;;1.1;BEH COMPONENTS;**005003,005004,005005,005009**;Mar 20, 2007
;=================================================================
;Added code to support eye, PHN and anticoag components
CHIEF(BEHVSIT,DFN,BEHQUIT) ;EP - chief complaint
;Find the chief complaint for this visit
;Modified to add qualifiers and to not display discontinued vitals
N BEHIEN,BEHTXT,BEHCNT,BEHNUM,I,J,NAME,X
S NAME="CHIEF COMPLAINT",BEHCNT=0
S BEHIEN=0
F D S BEHIEN=$O(^AUPNVNT("AD",BEHVSIT,BEHIEN)) Q:'BEHIEN
.S BEHNUM=0,X=$S(BEHIEN:"",1:$P($G(^AUPNVSIT(BEHVSIT,14)),U))
.F S BEHNUM=$O(^AUPNVNT(BEHIEN,11,BEHNUM)) Q:'BEHNUM D
..S X=X_$S($L(X):" ",1:"")_$G(^AUPNVNT(BEHIEN,11,BEHNUM,0))
.F Q:'$L(X) D
..S J=80,I=40
..F S I=$F(X," ",I) Q:'I!(I>80) S J=I
..S BEHCNT=BEHCNT+1,BEHTXT(BEHCNT)=$E(X,1,J-1),X=$E(X,J,9999)
I $D(BEHTXT) D
.D HDR^BEHOENPV(NAME,BEHCNT)
.F I=1:1:BEHCNT W !,BEHTXT(I)
Q
EXAMS(BEHVSIT,DFN,BEHQUIT) ;EP - exams
;Find the exams for this visit
N I,BEHIEN,BEHEXAM,BEHCNT,BEHEX,BEHRES,BEHCODE
S BEHCNT=0
S BEHIEN="" F S BEHIEN=$O(^AUPNVXAM("AD",BEHVSIT,BEHIEN)) Q:BEHIEN="" D
.S BEHEXAM=$$GET1^DIQ(9000010.13,BEHIEN,.01,"E")
.S BEHRES=$$GET1^DIQ(9000010.13,BEHIEN,.04,"E")
.S BEHCODE=$$GET1^DIQ(9000010.13,BEHIEN,.019,"E")
.S BEHCNT=BEHCNT+1
.S BEHEX(BEHCNT)=BEHEXAM_"^"_BEHCODE_"^"_BEHRES
I $D(BEHEX) D
.S NAME="PCC EXAMS"
.D HDR^BEHOENPV(NAME,BEHCNT)
.W !,"EXAM",?30,"CODE",?50,"RESULT",!
.F I=1:1:BEHCNT D
..W !,$P(BEHEX(I),U,1),?40,$P(BEHEX(I),U,2),?60,$P(BEHEX(I),U,3)
Q
FACTORS(BEHVSIT,DFN,BEHQUIT) ;EP - health factors
;Find the health factors for this visit
N I,BEHIEN,BEHHF,BEHCNT,BEHFAC
S BEHCNT=0
S BEHIEN="" F S BEHIEN=$O(^AUPNVHF("AD",BEHVSIT,BEHIEN)) Q:BEHIEN="" D
.S BEHHF=$$GET1^DIQ(9000010.23,BEHIEN,.01,"E")
.S BEHCNT=BEHCNT+1
.S BEHFAC(BEHCNT)=BEHHF
I $D(BEHFAC) D
.S NAME="HEALTH FACTORS"
.D HDR^BEHOENPV(NAME,BEHCNT)
.F I=1:1:BEHCNT D
..W !,BEHFAC(I)
Q
EDU(BEHVSIT,DFN,BEHQUIT) ;EP - education
;Find the education topics for this visit
N I,BEHIEN,BEHEDU,BEHCNT,BEHED,BEHLVL,BEHPRV
S BEHCNT=0
S BEHIEN="" F S BEHIEN=$O(^AUPNVPED("AD",BEHVSIT,BEHIEN)) Q:BEHIEN="" D
.S BEHEDU=$$GET1^DIQ(9000010.16,BEHIEN,.01,"E")
.S BEHLVL=$$GET1^DIQ(9000010.16,BEHIEN,.06,"E")
.S BEHPRV=$$GET1^DIQ(9000010.16,BEHIEN,.05,"E")
.S BEHCNT=BEHCNT+1,BEHED(BEHCNT)=BEHEDU_"^"_BEHLVL_"^"_BEHPRV
I $D(BEHED) D
.S NAME="PATIENT EDUCATION"
.D HDR^BEHOENPV(NAME,BEHCNT)
.W !,"EXAM",?40,"RESULT",?60,"PROVIDER",!
.F I=1:1:BEHCNT D
..W !,$P(BEHED(I),U,1),?40,$P(BEHED(I),U,2),?60,$P(BEHED(I),U,3)
Q Q
POV(BEHVSIT,DFN,BEHQUIT) ;EP - POV
;Find the POVs for this visit
N I,BEHIEN,BEHCODE,BEHCNT,BEHARRAY,BEHNAR,BEHST,TEXT
S BEHCNT=0
S BEHIEN="" F S BEHIEN=$O(^AUPNVPOV("AD",BEHVSIT,BEHIEN)) Q:BEHIEN="" D
.S BEHCODE=$$GET1^DIQ(9000010.07,BEHIEN,.01,"E")
.S BEHNAR=$$GET1^DIQ(9000010.07,BEHIEN,.04,"E")
.S BEHST=$$AUDIT(BEHVSIT)
.I BEHST'="R" S BEHCODE=BEHCODE_"*"
.S BEHCNT=BEHCNT+1
.S BEHARRAY(BEHCNT)=BEHCODE_"^"_BEHNAR
I $D(BEHARRAY) D
.S NAME="PURPOSE OF VISIT"
.D HDR^BEHOENPV(NAME,BEHCNT)
.S TEXT="Codes with an asterisk indicate an unverified code"
.W !,$$CJ^XLFSTR("<"_TEXT_">",IOM),!!
.W "ICD CODE",?15,"PROVIDER NARRATIVE",!
.F I=1:1:BEHCNT D
..W !,$P(BEHARRAY(I),U),?15,$$WRAP($P(BEHARRAY(I),U,2))
Q
MEAS(BEHVSIT,DFN,BEHQUIT) ;EP - Find the vital measurements for this visit
N BEHIEN,BEHEIE,BEHTYP,BEHVAL,BEHCNT,BEHVIT,VDATA,BEH,DEFAULT,DEFU,BEHDT,OLDBEHDT,MOD,QUAL,QUALSTR,PO2
;I '$$GET^XPAR("ALL","BEHOVM USE VMSR") D MEAS^BEHOENP2(BEHVSIT,DFN,BEHQUIT)
S BEHCNT=0,OLDBEHDT="",PO2=""
S BEHIEN="" F S BEHIEN=$O(^AUPNVMSR("AD",BEHVSIT,BEHIEN)) Q:BEHIEN="" D
.S BEHEIE=$$GET1^DIQ(9000010.01,BEHIEN,2,"I")
.Q:BEHEIE=1 ;Quit if entered in error
.S BEHTYP=$$GET1^DIQ(9000010.01,BEHIEN,.01,"E")
.I BEHTYP="O2" S PO2=$P($G(^AUPNVMSR(BEHIEN,0)),U,10)
.S BEH="" S BEH=$O(^BEHOVM(90460.01,"B",BEHTYP,BEH))
.Q:BEH=""
.I BEH'="" D
..S VDATA=$G(^BEHOVM(90460.01,BEH,0))
..S DEFAULT=$P(VDATA,U,2)
..I DEFAULT="" S DEFU=""
..I DEFAULT=1 D
...S DEFU=$P(VDATA,U,4)
..I DEFAULT=0 D
...S DEFU=$P(VDATA,U,3)
.S BEHVAL=$$RND($$GET1^DIQ(9000010.01,BEHIEN,.04,"E"))
.S BEHDT=$$GET1^DIQ(9000010.01,BEHIEN,1201,"E")
.S BEHDTI=$$GET1^DIQ(9000010.01,BEHIEN,1201,"I")
.;I BEHDT="" D
.;S BEHDT=$$GET1^DIQ(9000010.01,BEHIEN,.07,"E")
.;S BEHDTI=$$GET1^DIQ(9000010.01,BEHIEN,.07,"I")
.I BEHDT="" D
..S BEHDT=$$GET1^DIQ(9000010,BEHVSIT,.01,"E")
..S BEHDTI=$$GET1^DIQ(9000010,BEHVSIT,.01,"I")
.I BEHDT'=OLDBEHDT S BEHCNT=0,OLDBEHDT=BEHDT
.S QUALSTR=""
.I $D(^AUPNVMSR(BEHIEN,5))>0 D
..S MOD=0 F S MOD=$O(^AUPNVMSR(BEHIEN,5,MOD)) Q:'+MOD D
...S QUAL=$G(^AUPNVMSR(BEHIEN,5,MOD,0))
...S QUAL=$P($G(^GMRD(120.52,QUAL,0)),U,1)
...S QUALSTR=QUALSTR_QUAL_","
...I BEHTYP="O2"&(PO2'="") S QUALSTR=QUALSTR_" "_PO2
.S BEHCNT=BEHCNT+1
.S BEHVIT(BEHDTI,BEHCNT)=BEHTYP_U_BEHVAL_" "_DEFU_U_QUALSTR
I $D(BEHVIT) D
.S NAME="VITAL MEASUREMENTS"
.D HDR^BEHOENPV(NAME,BEHCNT)
.W !,"DT/TIME",?25,"TYPE",?40,"VALUE",?55,"MODIFIERS",!
.N I,J
.S I="" F S I=$O(BEHVIT(I)) Q:I="" D
..W !,$$FMTE^XLFDT(I)
..S J="" F S J=$O(BEHVIT(I,J)) Q:J="" D
...W !,?25,$P(BEHVIT(I,J),U,1),?40,$P(BEHVIT(I,J),U,2),?55,$P(BEHVIT(I,J),U,3)
Q
IMMUN(BEHVSIT,DFN,BEHQUIT) ;EP - Find the immunizations for this visit
N I,BEHIEN,BEHIMM,BEHCNT,BEHIM
S BEHCNT=0
S BEHIEN="" F S BEHIEN=$O(^AUPNVIMM("AD",BEHVSIT,BEHIEN)) Q:BEHIEN="" D
.S BEHIMM=$$GET1^DIQ(9000010.11,BEHIEN,.01,"E")
.S BEHCNT=BEHCNT+1,BEHIM(BEHCNT)=BEHIMM
I $D(BEHIM) D
.S NAME="IMMUNIZATIONS"
.D HDR^BEHOENPV(NAME,BEHCNT)
.F I=1:1:BEHCNT D
..W !,BEHIM(I)
Q
SKIN(BEHVSIT,DFN,BEHQUIT) ;EP - Find the skin tests for this visit
N I,BEHIEN,BEHSKN,BEHCNT,BEHTEST,BEHRES,BEHREAD
S BEHCNT=0
S BEHIEN="" F S BEHIEN=$O(^AUPNVSK("AD",BEHVSIT,BEHIEN)) Q:BEHIEN="" D
.S BEHSKN=$$GET1^DIQ(9000010.12,BEHIEN,.01,"E")
.S BEHRES=$$GET1^DIQ(9000010.12,BEHIEN,.04,"E")
.S BEHREAD=$$GET1^DIQ(9000010.12,BEHIEN,.05,"E")
.S BEHCNT=BEHCNT+1
.S BEHTEST(BEHCNT)=BEHSKN_"^"_BEHRES_"^"_BEHREAD
I $D(BEHTEST) D
.S NAME="SKIN TESTS"
.D HDR^BEHOENPV(NAME,BEHCNT)
.W !,"SKIN TEST",?30,"RESULTS",?60,"READING",!
.F I=1:1:BEHCNT D
..W !,$P(BEHTEST(I),U,1),?40,$P(BEHTEST(I),U,2),?60,$P(BEHTEST(I),U,3)
Q
CPT(BEHVSIT,DFN,BEHQUIT) ;EP - Find the CPT codes for this visit
N I,BEHIEN,BEHCODE,BEHCNT,BEHARRAY,BEHNAR,BEHST,TEXT
S BEHCNT=0
S BEHIEN="" F S BEHIEN=$O(^AUPNVCPT("AD",BEHVSIT,BEHIEN)) Q:BEHIEN="" D
.S BEHCODE=$$GET1^DIQ(9000010.18,BEHIEN,.01,"E")
.S BEHNAR=$$GET1^DIQ(9000010.18,BEHIEN,.04,"E")
.I BEHNAR="" S BEHNAR=$$GET1^DIQ(9000010.18,BEHIEN,.019,"E")
.S BEHST=$$AUDIT(BEHVSIT)
.I BEHST'="R" S BEHCODE=BEHCODE_"*"
.S BEHCNT=BEHCNT+1
.S BEHARRAY(BEHCNT)=BEHCODE_"^"_BEHNAR
I $D(BEHARRAY) D
.S NAME="E&M AND CPT CODES"
.D HDR^BEHOENPV(NAME,BEHCNT)
.S TEXT="Codes with an asterisk indicate an unverified code"
.W !,$$CJ^XLFSTR("<"_TEXT_">",IOM),!!
.W "CPT CODE",?15,"NARRATIVE",!
.F I=1:1:BEHCNT D
..W !,$P(BEHARRAY(I),U),?15,$$WRAP($P(BEHARRAY(I),U,2))
Q
PHN(BEHVSIT,DFN,BEHQUIT) ;EP - Find the PHN data for this visit
N I,BEHIEN,BEHLOI,BEHTOD,BEHCNT,BEHIM,PSYCH,NSG,SHORT,LONG,IEN
S BEHCNT=0
S BEHIEN="" F S BEHIEN=$O(^AUPNVPHN("AD",BEHVSIT,BEHIEN)) Q:BEHIEN="" D
.S BEHLOI=$$GET1^DIQ(9000010.32,BEHIEN,.05,"E")
.S BEHTOD=$$GET1^DIQ(9000010.32,BEHIEN,.06,"E")
.S BEHCNT=BEHCNT+1,BEHIM(BEHCNT)=BEHIEN_U_BEHLOI_U_BEHTOD
I $D(BEHIM) D
.S NAME="PHN DATA"
.D HDR^BEHOENPV(NAME,BEHCNT)
.F I=1:1:BEHCNT D
..W !,"LEVEL OF INTERVENTION: "_$P(BEHIM(I),U,2)
..W !,"TYPE OF DECISION: "_$P(BEHIM(I),U,3)
..S IEN=$P(BEHIM(I),U,1)
..S PSYCH=$G(^AUPNVPHN(IEN,21))
..S NSG=$G(^AUPNVPHN(IEN,22))
..S SHORT=$G(^AUPNVPHN(IEN,23))
..S LONG=$G(^AUPNVPHN(IEN,24))
..I PSYCH'="" W !,"PSYCH/SOCIAL/ENVIRON: "_PSYCH
..I NSG'="" W !,"NURSING DX: "_NSG
..I SHORT'="" W !,"SHORT TERM GOALS: "_SHORT
..I LONG'="" W !,"LONG TERM GOALS: "_LONG
Q
ANTICOAG(BEHVSIT,DFN,BEHQUIT) ;EP - Find the anticoag data for this visit
N I,X,BEHIEN,BEHWAR,BEHCNT,BEHIM,INRG,INRMIN,INRMAX,DUR,START,END
S BEHCNT=0
S BEHIEN="" F S BEHIEN=$O(^AUPNVACG("AD",BEHVSIT,BEHIEN)) Q:BEHIEN="" D
.S BEHWAR=$$GET1^DIQ(9000010.51,BEHIEN,.01,"E")
.S INRG=$$GET1^DIQ(9000010.51,BEHIEN,.04,"E")
.S INRMIN=$$GET1^DIQ(9000010.51,BEHIEN,.05,"E")
.S INRMAX=$$GET1^DIQ(9000010.51,BEHIEN,.06,"E")
.S DUR=$$GET1^DIQ(9000010.51,BEHIEN,.07,"E")
.S START=$$GET1^DIQ(9000010.51,BEHIEN,.08,"E")
.S END=$$GET1^DIQ(9000010.51,BEHIEN,.09,"E")
.S BEHCNT=BEHCNT+1,BEHIM(BEHCNT)=BEHWAR_U_INRG_U_INRMIN_U_INRMAX_U_DUR_U_START_U_END
I $D(BEHIM) D
.S NAME="ANTICOAG"
.D HDR^BEHOENPV(NAME,BEHCNT)
.F I=1:1:BEHCNT D
..S X="WARFARIN INDICATED: "_$P(BEHIM(I),U,1)
..I $P(BEHIM(I),U,2)'="" S X=X_" INR GOAL: "_$P(BEHIM(I),U,2)
..W !,X
..I $P(BEHIM(I),U,3)'="" D
...W !,"MIN VALUE: "_$P(BEHIM(I),U,3)_" MAX VALUE: "_$P(BEHIM(I),U,4)
..I $P(BEHIM(I),U,5)'="" D
...W !,"DURATION OF THERAPY: "_$P(BEHIM(I),U,5)
..I $P(BEHIM(I),U,6)'="" D
...W !,"START DATE: "_$P(BEHIM(I),U,6)_" END DATE: "_$P(BEHIM(I),U,7)
Q
EYE(BEHVSIT,DFN,BEHQUIT) ;EP - Find the eyeRX for this visit
N I,BEHIEN,BEHEYE,BEHCNT,BEHIM,X
S BEHCNT=0
S BEHIEN="" F S BEHIEN=$O(^AUPNVEYE("AD",BEHVSIT,BEHIEN)) Q:BEHIEN="" D
.S NAME="EYE RX"
.D HDR^BEHOENPV(NAME,BEHCNT)
.W !,"DRE SPHERE: "_$$GET1^DIQ(9000010.04,BEHIEN,1902,"E"),?40,"DLR SPHERE: "_$$GET1^DIQ(9000010.04,BEHIEN,1905,"E")
.W !,"DRE CYLINDER: "_$$GET1^DIQ(9000010.04,BEHIEN,1903,"E"),?40,"DLE CYLINDER: "_$$GET1^DIQ(9000010.04,BEHIEN,1906,"E")
.W !,"RE AXIS: "_$$GET1^DIQ(9000010.04,BEHIEN,1904,"E"),?40,"LE AXIS: "_$$GET1^DIQ(9000010.04,BEHIEN,1907,"E")
.W !,"RE PRISM H: "_$$GET1^DIQ(9000010.04,BEHIEN,1915,"E"),?40,"LE PRISM H: "_$$GET1^DIQ(9000010.04,BEHIEN,1916,"E")
.W !,"RE PRIXM V: "_$$GET1^DIQ(9000010.04,BEHIEN,1917,"E"),?40,"LE PRISM V: "_$$GET1^DIQ(9000010.04,BEHIEN,1918,"E")
.I $$GET1^DIQ(9000010.04,BEHIEN,1908,"E")'=""!($$GET1^DIQ(9000010.04,BEHIEN,1909,"E")'="") D
..W !,"READING ADD R: "_$$GET1^DIQ(9000010.04,BEHIEN,1908,"E"),?40,"READING ADD L: "_$$GET1^DIQ(9000010.04,BEHIEN,1909,"E")
.I $$GET1^DIQ(9000010.04,BEHIEN,1920,"E")'=""!($$GET1^DIQ(9000010.04,BEHIEN,1919,"E")'="") D
..W !,"PD (RIGHT): "_$$GET1^DIQ(9000010.04,BEHIEN,1920,"E"),?40,"PD (LEFT):"_$$GET1^DIQ(9000010.04,BEHIEN,1919,"E")
.I $$GET1^DIQ(9000010.01,BEHIEN,1914,"E")'=""!($$GET1^DIQ(9000010.04,BEHIEN,1913,"E")'="") D
..W !,"PD (DISTANCE): "_$$GET1^DIQ(9000010.04,BEHIEN,1914,"E"),?40,"PD (NEAR):"_$$GET1^DIQ(9000010.04,BEHIEN,1913,"E")
.W !,"Instructions: "_$P($G(^AUPNVEYE(BEHIEN,11)),"~",1)_" "_$P($G(^AUPNVEYE(BEHIEN,11)),"~",2)
Q
AUDIT(BEHVSIT) ;determine if the codes have been released from coding queue
N BEHID,BEHST
S BEHID=0
S BEHID=$O(^AUPNVCA("AD",BEHVSIT,BEHID))
I BEHID="" S BEHST="I"
I BEHID'="" D
.S BEHST=$$GET1^DIQ(9000010.45,BEHID,.04,"I")
Q BEHST
; Write text with word wrap
WRAP(TXT,RM) ;
N LM,WD,X,Y
S RM=$G(RM,IOM),LM=$X,WD=RM-LM
Q:WD<5 ""
F Q:'$L(TXT) D
.I $L(TXT)'>WD W TXT S TXT="" Q
.S X=0,Y=WD
.F S X=$F(TXT," ",X) Q:'X!(X>WD) S Y=X
.W $E(TXT,1,Y-1)
.S TXT=$E(TXT,Y,9999)
.W:$L(TXT) !?LM
Q ""
RND(X) Q $S(X=+X:+$J(X,0,2),1:X)
BEHOENPP ;MSC/IND/MGH - Summary Report for Selected Encounter ;21-Jan-2013 17:06;DU
+1 ;;1.1;BEH COMPONENTS;**005003,005004,005005,005009**;Mar 20, 2007
+2 ;=================================================================
+3 ;Added code to support eye, PHN and anticoag components
CHIEF(BEHVSIT,DFN,BEHQUIT) ;EP - chief complaint
+1 ;Find the chief complaint for this visit
+2 ;Modified to add qualifiers and to not display discontinued vitals
+3 NEW BEHIEN,BEHTXT,BEHCNT,BEHNUM,I,J,NAME,X
+4 SET NAME="CHIEF COMPLAINT"
SET BEHCNT=0
+5 SET BEHIEN=0
+6 FOR
Begin DoDot:1
+7 SET BEHNUM=0
SET X=$SELECT(BEHIEN:"",1:$PIECE($GET(^AUPNVSIT(BEHVSIT,14)),U))
+8 FOR
SET BEHNUM=$ORDER(^AUPNVNT(BEHIEN,11,BEHNUM))
IF 'BEHNUM
QUIT
Begin DoDot:2
+9 SET X=X_$SELECT($LENGTH(X):" ",1:"")_$GET(^AUPNVNT(BEHIEN,11,BEHNUM,0))
End DoDot:2
+10 FOR
IF '$LENGTH(X)
QUIT
Begin DoDot:2
+11 SET J=80
SET I=40
+12 FOR
SET I=$FIND(X," ",I)
IF 'I!(I>80)
QUIT
SET J=I
+13 SET BEHCNT=BEHCNT+1
SET BEHTXT(BEHCNT)=$EXTRACT(X,1,J-1)
SET X=$EXTRACT(X,J,9999)
End DoDot:2
End DoDot:1
SET BEHIEN=$ORDER(^AUPNVNT("AD",BEHVSIT,BEHIEN))
IF 'BEHIEN
QUIT
+14 IF $DATA(BEHTXT)
Begin DoDot:1
+15 DO HDR^BEHOENPV(NAME,BEHCNT)
+16 FOR I=1:1:BEHCNT
WRITE !,BEHTXT(I)
End DoDot:1
+17 QUIT
EXAMS(BEHVSIT,DFN,BEHQUIT) ;EP - exams
+1 ;Find the exams for this visit
+2 NEW I,BEHIEN,BEHEXAM,BEHCNT,BEHEX,BEHRES,BEHCODE
+3 SET BEHCNT=0
+4 SET BEHIEN=""
FOR
SET BEHIEN=$ORDER(^AUPNVXAM("AD",BEHVSIT,BEHIEN))
IF BEHIEN=""
QUIT
Begin DoDot:1
+5 SET BEHEXAM=$$GET1^DIQ(9000010.13,BEHIEN,.01,"E")
+6 SET BEHRES=$$GET1^DIQ(9000010.13,BEHIEN,.04,"E")
+7 SET BEHCODE=$$GET1^DIQ(9000010.13,BEHIEN,.019,"E")
+8 SET BEHCNT=BEHCNT+1
+9 SET BEHEX(BEHCNT)=BEHEXAM_"^"_BEHCODE_"^"_BEHRES
End DoDot:1
+10 IF $DATA(BEHEX)
Begin DoDot:1
+11 SET NAME="PCC EXAMS"
+12 DO HDR^BEHOENPV(NAME,BEHCNT)
+13 WRITE !,"EXAM",?30,"CODE",?50,"RESULT",!
+14 FOR I=1:1:BEHCNT
Begin DoDot:2
+15 WRITE !,$PIECE(BEHEX(I),U,1),?40,$PIECE(BEHEX(I),U,2),?60,$PIECE(BEHEX(I),U,3)
End DoDot:2
End DoDot:1
+16 QUIT
FACTORS(BEHVSIT,DFN,BEHQUIT) ;EP - health factors
+1 ;Find the health factors for this visit
+2 NEW I,BEHIEN,BEHHF,BEHCNT,BEHFAC
+3 SET BEHCNT=0
+4 SET BEHIEN=""
FOR
SET BEHIEN=$ORDER(^AUPNVHF("AD",BEHVSIT,BEHIEN))
IF BEHIEN=""
QUIT
Begin DoDot:1
+5 SET BEHHF=$$GET1^DIQ(9000010.23,BEHIEN,.01,"E")
+6 SET BEHCNT=BEHCNT+1
+7 SET BEHFAC(BEHCNT)=BEHHF
End DoDot:1
+8 IF $DATA(BEHFAC)
Begin DoDot:1
+9 SET NAME="HEALTH FACTORS"
+10 DO HDR^BEHOENPV(NAME,BEHCNT)
+11 FOR I=1:1:BEHCNT
Begin DoDot:2
+12 WRITE !,BEHFAC(I)
End DoDot:2
End DoDot:1
+13 QUIT
EDU(BEHVSIT,DFN,BEHQUIT) ;EP - education
+1 ;Find the education topics for this visit
+2 NEW I,BEHIEN,BEHEDU,BEHCNT,BEHED,BEHLVL,BEHPRV
+3 SET BEHCNT=0
+4 SET BEHIEN=""
FOR
SET BEHIEN=$ORDER(^AUPNVPED("AD",BEHVSIT,BEHIEN))
IF BEHIEN=""
QUIT
Begin DoDot:1
+5 SET BEHEDU=$$GET1^DIQ(9000010.16,BEHIEN,.01,"E")
+6 SET BEHLVL=$$GET1^DIQ(9000010.16,BEHIEN,.06,"E")
+7 SET BEHPRV=$$GET1^DIQ(9000010.16,BEHIEN,.05,"E")
+8 SET BEHCNT=BEHCNT+1
SET BEHED(BEHCNT)=BEHEDU_"^"_BEHLVL_"^"_BEHPRV
End DoDot:1
+9 IF $DATA(BEHED)
Begin DoDot:1
+10 SET NAME="PATIENT EDUCATION"
+11 DO HDR^BEHOENPV(NAME,BEHCNT)
+12 WRITE !,"EXAM",?40,"RESULT",?60,"PROVIDER",!
+13 FOR I=1:1:BEHCNT
Begin DoDot:2
+14 WRITE !,$PIECE(BEHED(I),U,1),?40,$PIECE(BEHED(I),U,2),?60,$PIECE(BEHED(I),U,3)
End DoDot:2
End DoDot:1
+15 QUIT
QUIT
POV(BEHVSIT,DFN,BEHQUIT) ;EP - POV
+1 ;Find the POVs for this visit
+2 NEW I,BEHIEN,BEHCODE,BEHCNT,BEHARRAY,BEHNAR,BEHST,TEXT
+3 SET BEHCNT=0
+4 SET BEHIEN=""
FOR
SET BEHIEN=$ORDER(^AUPNVPOV("AD",BEHVSIT,BEHIEN))
IF BEHIEN=""
QUIT
Begin DoDot:1
+5 SET BEHCODE=$$GET1^DIQ(9000010.07,BEHIEN,.01,"E")
+6 SET BEHNAR=$$GET1^DIQ(9000010.07,BEHIEN,.04,"E")
+7 SET BEHST=$$AUDIT(BEHVSIT)
+8 IF BEHST'="R"
SET BEHCODE=BEHCODE_"*"
+9 SET BEHCNT=BEHCNT+1
+10 SET BEHARRAY(BEHCNT)=BEHCODE_"^"_BEHNAR
End DoDot:1
+11 IF $DATA(BEHARRAY)
Begin DoDot:1
+12 SET NAME="PURPOSE OF VISIT"
+13 DO HDR^BEHOENPV(NAME,BEHCNT)
+14 SET TEXT="Codes with an asterisk indicate an unverified code"
+15 WRITE !,$$CJ^XLFSTR("<"_TEXT_">",IOM),!!
+16 WRITE "ICD CODE",?15,"PROVIDER NARRATIVE",!
+17 FOR I=1:1:BEHCNT
Begin DoDot:2
+18 WRITE !,$PIECE(BEHARRAY(I),U),?15,$$WRAP($PIECE(BEHARRAY(I),U,2))
End DoDot:2
End DoDot:1
+19 QUIT
MEAS(BEHVSIT,DFN,BEHQUIT) ;EP - Find the vital measurements for this visit
+1 NEW BEHIEN,BEHEIE,BEHTYP,BEHVAL,BEHCNT,BEHVIT,VDATA,BEH,DEFAULT,DEFU,BEHDT,OLDBEHDT,MOD,QUAL,QUALSTR,PO2
+2 ;I '$$GET^XPAR("ALL","BEHOVM USE VMSR") D MEAS^BEHOENP2(BEHVSIT,DFN,BEHQUIT)
+3 SET BEHCNT=0
SET OLDBEHDT=""
SET PO2=""
+4 SET BEHIEN=""
FOR
SET BEHIEN=$ORDER(^AUPNVMSR("AD",BEHVSIT,BEHIEN))
IF BEHIEN=""
QUIT
Begin DoDot:1
+5 SET BEHEIE=$$GET1^DIQ(9000010.01,BEHIEN,2,"I")
+6 ;Quit if entered in error
IF BEHEIE=1
QUIT
+7 SET BEHTYP=$$GET1^DIQ(9000010.01,BEHIEN,.01,"E")
+8 IF BEHTYP="O2"
SET PO2=$PIECE($GET(^AUPNVMSR(BEHIEN,0)),U,10)
+9 SET BEH=""
SET BEH=$ORDER(^BEHOVM(90460.01,"B",BEHTYP,BEH))
+10 IF BEH=""
QUIT
+11 IF BEH'=""
Begin DoDot:2
+12 SET VDATA=$GET(^BEHOVM(90460.01,BEH,0))
+13 SET DEFAULT=$PIECE(VDATA,U,2)
+14 IF DEFAULT=""
SET DEFU=""
+15 IF DEFAULT=1
Begin DoDot:3
+16 SET DEFU=$PIECE(VDATA,U,4)
End DoDot:3
+17 IF DEFAULT=0
Begin DoDot:3
+18 SET DEFU=$PIECE(VDATA,U,3)
End DoDot:3
End DoDot:2
+19 SET BEHVAL=$$RND($$GET1^DIQ(9000010.01,BEHIEN,.04,"E"))
+20 SET BEHDT=$$GET1^DIQ(9000010.01,BEHIEN,1201,"E")
+21 SET BEHDTI=$$GET1^DIQ(9000010.01,BEHIEN,1201,"I")
+22 ;I BEHDT="" D
+23 ;S BEHDT=$$GET1^DIQ(9000010.01,BEHIEN,.07,"E")
+24 ;S BEHDTI=$$GET1^DIQ(9000010.01,BEHIEN,.07,"I")
+25 IF BEHDT=""
Begin DoDot:2
+26 SET BEHDT=$$GET1^DIQ(9000010,BEHVSIT,.01,"E")
+27 SET BEHDTI=$$GET1^DIQ(9000010,BEHVSIT,.01,"I")
End DoDot:2
+28 IF BEHDT'=OLDBEHDT
SET BEHCNT=0
SET OLDBEHDT=BEHDT
+29 SET QUALSTR=""
+30 IF $DATA(^AUPNVMSR(BEHIEN,5))>0
Begin DoDot:2
+31 SET MOD=0
FOR
SET MOD=$ORDER(^AUPNVMSR(BEHIEN,5,MOD))
IF '+MOD
QUIT
Begin DoDot:3
+32 SET QUAL=$GET(^AUPNVMSR(BEHIEN,5,MOD,0))
+33 SET QUAL=$PIECE($GET(^GMRD(120.52,QUAL,0)),U,1)
+34 SET QUALSTR=QUALSTR_QUAL_","
+35 IF BEHTYP="O2"&(PO2'="")
SET QUALSTR=QUALSTR_" "_PO2
End DoDot:3
End DoDot:2
+36 SET BEHCNT=BEHCNT+1
+37 SET BEHVIT(BEHDTI,BEHCNT)=BEHTYP_U_BEHVAL_" "_DEFU_U_QUALSTR
End DoDot:1
+38 IF $DATA(BEHVIT)
Begin DoDot:1
+39 SET NAME="VITAL MEASUREMENTS"
+40 DO HDR^BEHOENPV(NAME,BEHCNT)
+41 WRITE !,"DT/TIME",?25,"TYPE",?40,"VALUE",?55,"MODIFIERS",!
+42 NEW I,J
+43 SET I=""
FOR
SET I=$ORDER(BEHVIT(I))
IF I=""
QUIT
Begin DoDot:2
+44 WRITE !,$$FMTE^XLFDT(I)
+45 SET J=""
FOR
SET J=$ORDER(BEHVIT(I,J))
IF J=""
QUIT
Begin DoDot:3
+46 WRITE !,?25,$PIECE(BEHVIT(I,J),U,1),?40,$PIECE(BEHVIT(I,J),U,2),?55,$PIECE(BEHVIT(I,J),U,3)
End DoDot:3
End DoDot:2
End DoDot:1
+47 QUIT
IMMUN(BEHVSIT,DFN,BEHQUIT) ;EP - Find the immunizations for this visit
+1 NEW I,BEHIEN,BEHIMM,BEHCNT,BEHIM
+2 SET BEHCNT=0
+3 SET BEHIEN=""
FOR
SET BEHIEN=$ORDER(^AUPNVIMM("AD",BEHVSIT,BEHIEN))
IF BEHIEN=""
QUIT
Begin DoDot:1
+4 SET BEHIMM=$$GET1^DIQ(9000010.11,BEHIEN,.01,"E")
+5 SET BEHCNT=BEHCNT+1
SET BEHIM(BEHCNT)=BEHIMM
End DoDot:1
+6 IF $DATA(BEHIM)
Begin DoDot:1
+7 SET NAME="IMMUNIZATIONS"
+8 DO HDR^BEHOENPV(NAME,BEHCNT)
+9 FOR I=1:1:BEHCNT
Begin DoDot:2
+10 WRITE !,BEHIM(I)
End DoDot:2
End DoDot:1
+11 QUIT
SKIN(BEHVSIT,DFN,BEHQUIT) ;EP - Find the skin tests for this visit
+1 NEW I,BEHIEN,BEHSKN,BEHCNT,BEHTEST,BEHRES,BEHREAD
+2 SET BEHCNT=0
+3 SET BEHIEN=""
FOR
SET BEHIEN=$ORDER(^AUPNVSK("AD",BEHVSIT,BEHIEN))
IF BEHIEN=""
QUIT
Begin DoDot:1
+4 SET BEHSKN=$$GET1^DIQ(9000010.12,BEHIEN,.01,"E")
+5 SET BEHRES=$$GET1^DIQ(9000010.12,BEHIEN,.04,"E")
+6 SET BEHREAD=$$GET1^DIQ(9000010.12,BEHIEN,.05,"E")
+7 SET BEHCNT=BEHCNT+1
+8 SET BEHTEST(BEHCNT)=BEHSKN_"^"_BEHRES_"^"_BEHREAD
End DoDot:1
+9 IF $DATA(BEHTEST)
Begin DoDot:1
+10 SET NAME="SKIN TESTS"
+11 DO HDR^BEHOENPV(NAME,BEHCNT)
+12 WRITE !,"SKIN TEST",?30,"RESULTS",?60,"READING",!
+13 FOR I=1:1:BEHCNT
Begin DoDot:2
+14 WRITE !,$PIECE(BEHTEST(I),U,1),?40,$PIECE(BEHTEST(I),U,2),?60,$PIECE(BEHTEST(I),U,3)
End DoDot:2
End DoDot:1
+15 QUIT
CPT(BEHVSIT,DFN,BEHQUIT) ;EP - Find the CPT codes for this visit
+1 NEW I,BEHIEN,BEHCODE,BEHCNT,BEHARRAY,BEHNAR,BEHST,TEXT
+2 SET BEHCNT=0
+3 SET BEHIEN=""
FOR
SET BEHIEN=$ORDER(^AUPNVCPT("AD",BEHVSIT,BEHIEN))
IF BEHIEN=""
QUIT
Begin DoDot:1
+4 SET BEHCODE=$$GET1^DIQ(9000010.18,BEHIEN,.01,"E")
+5 SET BEHNAR=$$GET1^DIQ(9000010.18,BEHIEN,.04,"E")
+6 IF BEHNAR=""
SET BEHNAR=$$GET1^DIQ(9000010.18,BEHIEN,.019,"E")
+7 SET BEHST=$$AUDIT(BEHVSIT)
+8 IF BEHST'="R"
SET BEHCODE=BEHCODE_"*"
+9 SET BEHCNT=BEHCNT+1
+10 SET BEHARRAY(BEHCNT)=BEHCODE_"^"_BEHNAR
End DoDot:1
+11 IF $DATA(BEHARRAY)
Begin DoDot:1
+12 SET NAME="E&M AND CPT CODES"
+13 DO HDR^BEHOENPV(NAME,BEHCNT)
+14 SET TEXT="Codes with an asterisk indicate an unverified code"
+15 WRITE !,$$CJ^XLFSTR("<"_TEXT_">",IOM),!!
+16 WRITE "CPT CODE",?15,"NARRATIVE",!
+17 FOR I=1:1:BEHCNT
Begin DoDot:2
+18 WRITE !,$PIECE(BEHARRAY(I),U),?15,$$WRAP($PIECE(BEHARRAY(I),U,2))
End DoDot:2
End DoDot:1
+19 QUIT
PHN(BEHVSIT,DFN,BEHQUIT) ;EP - Find the PHN data for this visit
+1 NEW I,BEHIEN,BEHLOI,BEHTOD,BEHCNT,BEHIM,PSYCH,NSG,SHORT,LONG,IEN
+2 SET BEHCNT=0
+3 SET BEHIEN=""
FOR
SET BEHIEN=$ORDER(^AUPNVPHN("AD",BEHVSIT,BEHIEN))
IF BEHIEN=""
QUIT
Begin DoDot:1
+4 SET BEHLOI=$$GET1^DIQ(9000010.32,BEHIEN,.05,"E")
+5 SET BEHTOD=$$GET1^DIQ(9000010.32,BEHIEN,.06,"E")
+6 SET BEHCNT=BEHCNT+1
SET BEHIM(BEHCNT)=BEHIEN_U_BEHLOI_U_BEHTOD
End DoDot:1
+7 IF $DATA(BEHIM)
Begin DoDot:1
+8 SET NAME="PHN DATA"
+9 DO HDR^BEHOENPV(NAME,BEHCNT)
+10 FOR I=1:1:BEHCNT
Begin DoDot:2
+11 WRITE !,"LEVEL OF INTERVENTION: "_$PIECE(BEHIM(I),U,2)
+12 WRITE !,"TYPE OF DECISION: "_$PIECE(BEHIM(I),U,3)
+13 SET IEN=$PIECE(BEHIM(I),U,1)
+14 SET PSYCH=$GET(^AUPNVPHN(IEN,21))
+15 SET NSG=$GET(^AUPNVPHN(IEN,22))
+16 SET SHORT=$GET(^AUPNVPHN(IEN,23))
+17 SET LONG=$GET(^AUPNVPHN(IEN,24))
+18 IF PSYCH'=""
WRITE !,"PSYCH/SOCIAL/ENVIRON: "_PSYCH
+19 IF NSG'=""
WRITE !,"NURSING DX: "_NSG
+20 IF SHORT'=""
WRITE !,"SHORT TERM GOALS: "_SHORT
+21 IF LONG'=""
WRITE !,"LONG TERM GOALS: "_LONG
End DoDot:2
End DoDot:1
+22 QUIT
ANTICOAG(BEHVSIT,DFN,BEHQUIT) ;EP - Find the anticoag data for this visit
+1 NEW I,X,BEHIEN,BEHWAR,BEHCNT,BEHIM,INRG,INRMIN,INRMAX,DUR,START,END
+2 SET BEHCNT=0
+3 SET BEHIEN=""
FOR
SET BEHIEN=$ORDER(^AUPNVACG("AD",BEHVSIT,BEHIEN))
IF BEHIEN=""
QUIT
Begin DoDot:1
+4 SET BEHWAR=$$GET1^DIQ(9000010.51,BEHIEN,.01,"E")
+5 SET INRG=$$GET1^DIQ(9000010.51,BEHIEN,.04,"E")
+6 SET INRMIN=$$GET1^DIQ(9000010.51,BEHIEN,.05,"E")
+7 SET INRMAX=$$GET1^DIQ(9000010.51,BEHIEN,.06,"E")
+8 SET DUR=$$GET1^DIQ(9000010.51,BEHIEN,.07,"E")
+9 SET START=$$GET1^DIQ(9000010.51,BEHIEN,.08,"E")
+10 SET END=$$GET1^DIQ(9000010.51,BEHIEN,.09,"E")
+11 SET BEHCNT=BEHCNT+1
SET BEHIM(BEHCNT)=BEHWAR_U_INRG_U_INRMIN_U_INRMAX_U_DUR_U_START_U_END
End DoDot:1
+12 IF $DATA(BEHIM)
Begin DoDot:1
+13 SET NAME="ANTICOAG"
+14 DO HDR^BEHOENPV(NAME,BEHCNT)
+15 FOR I=1:1:BEHCNT
Begin DoDot:2
+16 SET X="WARFARIN INDICATED: "_$PIECE(BEHIM(I),U,1)
+17 IF $PIECE(BEHIM(I),U,2)'=""
SET X=X_" INR GOAL: "_$PIECE(BEHIM(I),U,2)
+18 WRITE !,X
+19 IF $PIECE(BEHIM(I),U,3)'=""
Begin DoDot:3
+20 WRITE !,"MIN VALUE: "_$PIECE(BEHIM(I),U,3)_" MAX VALUE: "_$PIECE(BEHIM(I),U,4)
End DoDot:3
+21 IF $PIECE(BEHIM(I),U,5)'=""
Begin DoDot:3
+22 WRITE !,"DURATION OF THERAPY: "_$PIECE(BEHIM(I),U,5)
End DoDot:3
+23 IF $PIECE(BEHIM(I),U,6)'=""
Begin DoDot:3
+24 WRITE !,"START DATE: "_$PIECE(BEHIM(I),U,6)_" END DATE: "_$PIECE(BEHIM(I),U,7)
End DoDot:3
End DoDot:2
End DoDot:1
+25 QUIT
EYE(BEHVSIT,DFN,BEHQUIT) ;EP - Find the eyeRX for this visit
+1 NEW I,BEHIEN,BEHEYE,BEHCNT,BEHIM,X
+2 SET BEHCNT=0
+3 SET BEHIEN=""
FOR
SET BEHIEN=$ORDER(^AUPNVEYE("AD",BEHVSIT,BEHIEN))
IF BEHIEN=""
QUIT
Begin DoDot:1
+4 SET NAME="EYE RX"
+5 DO HDR^BEHOENPV(NAME,BEHCNT)
+6 WRITE !,"DRE SPHERE: "_$$GET1^DIQ(9000010.04,BEHIEN,1902,"E"),?40,"DLR SPHERE: "_$$GET1^DIQ(9000010.04,BEHIEN,1905,"E")
+7 WRITE !,"DRE CYLINDER: "_$$GET1^DIQ(9000010.04,BEHIEN,1903,"E"),?40,"DLE CYLINDER: "_$$GET1^DIQ(9000010.04,BEHIEN,1906,"E")
+8 WRITE !,"RE AXIS: "_$$GET1^DIQ(9000010.04,BEHIEN,1904,"E"),?40,"LE AXIS: "_$$GET1^DIQ(9000010.04,BEHIEN,1907,"E")
+9 WRITE !,"RE PRISM H: "_$$GET1^DIQ(9000010.04,BEHIEN,1915,"E"),?40,"LE PRISM H: "_$$GET1^DIQ(9000010.04,BEHIEN,1916,"E")
+10 WRITE !,"RE PRIXM V: "_$$GET1^DIQ(9000010.04,BEHIEN,1917,"E"),?40,"LE PRISM V: "_$$GET1^DIQ(9000010.04,BEHIEN,1918,"E")
+11 IF $$GET1^DIQ(9000010.04,BEHIEN,1908,"E")'=""!($$GET1^DIQ(9000010.04,BEHIEN,1909,"E")'="")
Begin DoDot:2
+12 WRITE !,"READING ADD R: "_$$GET1^DIQ(9000010.04,BEHIEN,1908,"E"),?40,"READING ADD L: "_$$GET1^DIQ(9000010.04,BEHIEN,1909,"E")
End DoDot:2
+13 IF $$GET1^DIQ(9000010.04,BEHIEN,1920,"E")'=""!($$GET1^DIQ(9000010.04,BEHIEN,1919,"E")'="")
Begin DoDot:2
+14 WRITE !,"PD (RIGHT): "_$$GET1^DIQ(9000010.04,BEHIEN,1920,"E"),?40,"PD (LEFT):"_$$GET1^DIQ(9000010.04,BEHIEN,1919,"E")
End DoDot:2
+15 IF $$GET1^DIQ(9000010.01,BEHIEN,1914,"E")'=""!($$GET1^DIQ(9000010.04,BEHIEN,1913,"E")'="")
Begin DoDot:2
+16 WRITE !,"PD (DISTANCE): "_$$GET1^DIQ(9000010.04,BEHIEN,1914,"E"),?40,"PD (NEAR):"_$$GET1^DIQ(9000010.04,BEHIEN,1913,"E")
End DoDot:2
+17 WRITE !,"Instructions: "_$PIECE($GET(^AUPNVEYE(BEHIEN,11)),"~",1)_" "_$PIECE($GET(^AUPNVEYE(BEHIEN,11)),"~",2)
End DoDot:1
+18 QUIT
AUDIT(BEHVSIT) ;determine if the codes have been released from coding queue
+1 NEW BEHID,BEHST
+2 SET BEHID=0
+3 SET BEHID=$ORDER(^AUPNVCA("AD",BEHVSIT,BEHID))
+4 IF BEHID=""
SET BEHST="I"
+5 IF BEHID'=""
Begin DoDot:1
+6 SET BEHST=$$GET1^DIQ(9000010.45,BEHID,.04,"I")
End DoDot:1
+7 QUIT BEHST
+8 ; Write text with word wrap
WRAP(TXT,RM) ;
+1 NEW LM,WD,X,Y
+2 SET RM=$GET(RM,IOM)
SET LM=$X
SET WD=RM-LM
+3 IF WD<5
QUIT ""
+4 FOR
IF '$LENGTH(TXT)
QUIT
Begin DoDot:1
+5 IF $LENGTH(TXT)'>WD
WRITE TXT
SET TXT=""
QUIT
+6 SET X=0
SET Y=WD
+7 FOR
SET X=$FIND(TXT," ",X)
IF 'X!(X>WD)
QUIT
SET Y=X
+8 WRITE $EXTRACT(TXT,1,Y-1)
+9 SET TXT=$EXTRACT(TXT,Y,9999)
+10 IF $LENGTH(TXT)
WRITE !?LM
End DoDot:1
+11 QUIT ""
RND(X) QUIT $SELECT(X=+X:+$JUSTIFY(X,0,2),1:X)
