Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BEHOENPP

BEHOENPP.m

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