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

BGOTRG.m

Go to the documentation of this file. 
  1. BGOTRG ; IHS/BAO/TMD - Triage Summary ;06-Nov-2014 10:33;DU
  1.  ;;1.1;BGO COMPONENTS;**1,3,5,6,7,8,11,14**;Mar 20, 2007
  1.  ; RPC: Returns triage summary information
  1.  ;  INP = Visit IEN ^ Provider ^ Report List ^ Include CC Author
  1. GETSUM(RET,INP) ;EP
  1.  N VIEN,V0,DFN,DAT,PRV,CTL,RTN,SEQ,SCT,SEX
  1.  S RET=$$TMPGBL^BGOUTL
  1.  S VIEN=+INP
  1.  Q:'VIEN
  1.  S V0=$G(^AUPNVSIT(VIEN,0))
  1.  Q:'V0
  1.  S DAT=V0\1,DFN=+$P(V0,U,5),SEX=$P($G(^DPT(DFN,0)),U,2)
  1.  S PRV=$P(INP,U,2)
  1.  S:'PRV PRV=+$$PRIPRV^BGOUTL(VIEN)
  1.  S CTL=$TR($P(INP,U,3),";-",",")
  1.  S:CTL="" CTL="1,2,3,4,5,6,7,8,9,10,11"
  1.  F SEQ=1:1 Q:'$L(CTL)  S SEQ(SEQ)=$P(CTL,",")\1,CTL=$P(CTL,",",2,999)
  1.  S (SEQ,SCT)=0
  1.  F  S SEQ=$O(SEQ(SEQ)) Q:'SEQ  D
  1.  .N LP,CNT
  1.  .S RTN="GET"_SEQ(SEQ)
  1.  .S CTL=$P($T(@RTN),";;",2,999)
  1.  .Q:'$L(CTL)
  1.  .S (CNT,LP)=0
  1.  .D @RTN,ADDHDR
  1.  Q
  1. GET1 ;;Chief Complaint^
  1.  N CC,TYPE,AUTH,X,N
  1.  S TYPE=$O(^AUTTNTYP("B","CHIEF COMPLAINT",0))
  1.  Q:'TYPE
  1.  S AUTH=+$P(INP,U,4)
  1.  F  S LP=$O(^AUPNVNT("AD",VIEN,LP)) Q:'LP  D
  1.  .Q:$P($G(^AUPNVNT(LP,0)),U)'=TYPE
  1.  .I AUTH D
  1.  ..S X=$P($G(^AUPNVNT(LP,12)),U,4)
  1.  ..D:X APPEND($P($G(^VA(200,X,0)),U)_":")
  1.  .S N=0
  1.  .F  S N=$O(^AUPNVNT(LP,11,N)) Q:'N  D APPEND($G(^(N,0)))
  1.  .D ADDHDR
  1.  S X=$P($G(^AUPNVSIT(VIEN,14)),U)
  1.  D:$L(X) APPEND(X)
  1.  Q
  1. GET2 ;;Vitals^;
  1.  N MSR,TYP,EIE,VAL,VAL2,AGE,X,WT,HT,MR,BEH,DATA,DEFAULT,DEFU,ALTU,A
  1.  N QUALS,QUALN,QUALIF
  1.  S VMSR=$$VMSR^BEHOVM
  1.  N GLOB S GLOB=$S('VMSR:"^GMR(120.5)",1:"^AUPNVMSR")
  1.  ;F  S LP=$O(^AUPNVMSR("AD",VIEN,LP)) Q:'LP  D
  1.  ;.S MSR=$G(^AUPNVMSR(LP,0)),X=+$G(^(12))
  1.  F  S LP=$O(@GLOB@("AD",VIEN,LP)) Q:'LP  D
  1.  .S MSR=$G(@GLOB@(LP,0)),X=+$G(^($S('VMSR:0,1:12)))
  1.  .Q:'MSR
  1.  .;IHS/MSC/MGH  Quit if entered in error
  1.  .S EIE=$$GET1^DIQ(9000010.01,LP,2,"I")
  1.  .Q:EIE=1
  1.  .S QUALIF=""
  1.  .S QUALS=0 F  S QUALS=$O(@GLOB@(LP,5,QUALS)) Q:QUALS=""  D
  1.  ..S QUALN=$P($G(@GLOB@(LP,5,QUALS,0)),U,1)
  1.  ..I +QUALN S QUALN=$P($G(^GMRD(120.52,QUALN,0)),U,1)
  1.  ..I QUALIF'="" S QUALIF=QUALIF_","_QUALN
  1.  ..E  I QUALIF="" S QUALIF=QUALN
  1.  .S TYP=$P($S('VMSR:$G(^GMRD(120.51,+$P(MSR,U,3),0)),1:$G(^AUTTMSR(+MSR,0))),U),VAL=$P(MSR,U,$S('VMSR:8,1:4)),MR=""
  1.  .I TYP="O2"!(TYP="PO2") S QUALIF=QUALIF_$P($G(@GLOB@(LP,0)),U,10)
  1.  .;S TYP=$P(^AUTTMSR(+MSR,0),U),VAL=$P(MSR,U,4),MR=""
  1.  .S BEH="" I 'VMSR N A,I F I=7,2 D  Q:BEH
  1.  ..S A=$P($G(^GMRD(120.51,+$P(MSR,U,3),0)),U,I) I A'="" S BEH=$O(^BEHOVM(90460.01,"B",A,0))
  1.  .S AGE=$$PTAGE^BGOUTL(DFN,$S(X:X,1:DAT))
  1.  .I VMSR S BEH="" S BEH=$O(^BEHOVM(90460.01,"B",TYP,BEH))
  1.  .I TYP="" D APPEND(TYP_": "_$$RND(VAL),MR,QUALIF)
  1.  .E  D
  1.  ..S DATA=$G(^BEHOVM(90460.01,BEH,0))
  1.  ..S DEFAULT=$P(DATA,U,2)
  1.  ..I DEFAULT=1 D
  1.  ...S DEFU=$P(DATA,U,4),ALTU=$P(DATA,U,3)
  1.  ...I ALTU=""!(DEFU=ALTU) D APPEND(TYP_": "_$$RND(VAL)_" "_DEFU,,QUALIF)
  1.  ...E  S X=VAL I $D(^BEHOVM(90460.01,BEH,2)) X $G(^BEHOVM(90460.01,BEH,2)) D APPEND(TYP_": "_$$RND(VAL)_" "_DEFU_" ",$$RND(X)_" "_ALTU,QUALIF)
  1.  ..I DEFAULT=0 D
  1.  ...S DEFU=$P(DATA,U,3),ALTU=$P(DATA,U,4)
  1.  ...I ALTU=""!(DEFU=ALTU) D APPEND(TYP_": "_$$RND(VAL)_" "_DEFU,,QUALIF)
  1.  ...E  S X=VAL I $D(^BEHOVM(90460.01,BEH,1)) X $G(^BEHOVM(90460.01,BEH,1)) D APPEND(TYP_": "_$$RND(VAL)_" "_DEFU_" ",$$RND(X)_" "_ALTU,QUALIF)
  1.  ..I DEFAULT="" D APPEND(TYP_": "_$$RND(VAL),,QUALIF)
  1.  Q:$G(AGE)'>2!'$D(WT)!'$D(HT)
  1.  S VAL=$$RND((WT*704.5)/(HT*HT))
  1.  S MR=$S(AGE<20:"",VAL<18.5:"Underweight",VAL<25:"Normal Weight",VAL<30:"Overweight",VAL<35:"Obesity - Class 1",VAL<40:"Obesity - Class 2",1:"Extreme Obesity")
  1.  D APPEND("BMI: "_VAL,MR)
  1.  Q
  1. GET3 ;;Reproductive^;
  1.  N REC,X
  1.  S REC=$G(^AUPNREP(DFN,0))
  1.  Q:'$L(REC)!(SEX'="F")
  1.  ;IHS/MSC/MGH Patch 6 updated to reflect the change in date fields in reproductive hx
  1.  ;S X=$S($P(REC,U,3)=DAT:$P(REC,U,2),1:"")
  1.  S TODAY=$$DT^XLFDT
  1.  Q:TODAY'=$P(REC,U,3)
  1.  S:$L($T(^BGOREP)) X=$$EXPHX^BGOREP($P(REC,U))
  1.  D:$L(X) APPEND($TR(X,"=",":"))
  1.  S X=$S($P(REC,U,5)=DAT:$P(REC,U,4),1:"")
  1.  D:X APPEND("LMP: "_$$FMTDATE^BGOUTL(X))
  1.  S X=$S($P(REC,U,8)=DAT:$$MCASE^BGOUTL($$EXTERNAL^DILFD(9000017,3,,$P(REC,U,6))),1:"")
  1.  D:$L(X) APPEND("Contraceptive Method: "_X)
  1.  Q
  1. GET4 ;;Pregnancy^;
  1.  N REC,X
  1.  Q:SEX'="F"
  1.  S REC=$G(^AUPNREP(DFN,0))
  1.  S X=$S($P(REC,U,11)=DAT:$$FMTDATE^BGOUTL($P(REC,U,9)),1:"")
  1.  D:$L(X) APPEND("Est. Delivery: "_X)
  1.  Q
  1. GET5 ;;Immunizations^;
  1.  N IMM
  1.  F  S LP=$O(^AUPNVIMM("AD",+VIEN,LP)) Q:'LP  D
  1.  .S IMM=$P($G(^AUPNVIMM(LP,0)),U)
  1.  .D:IMM APPEND($P($G(^AUTTIMM(IMM,0)),U))
  1.  Q
  1. GET6 ;;Skin Tests^;
  1.  N SK
  1.  F  S LP=$O(^AUPNVSK("AD",+VIEN,LP)) Q:'LP  D
  1.  .S SK=$P($G(^AUPNVSK(LP,0)),U)
  1.  .D:SK APPEND($P($G(^AUTTSK(SK,0)),U))
  1.  Q
  1. GET7 ;;Education^;
  1.  N EDT,TXT,SNO,X
  1.  F  S LP=$O(^AUPNVPED("AD",VIEN,LP)) Q:'LP  D
  1.  .S EDT=$P($G(^AUPNVPED(LP,0)),U)
  1.  .Q:'EDT
  1.  .I $P($G(^AUTTEDT(EDT,0)),U,12)'="" D
  1.  ..S TXT=""
  1.  ..S SNO=$P($G(^AUTTEDT(EDT,0)),U,12)
  1.  ..;IHS/MSC/MGH changed to use new api
  1.  ..;S IN=SNO_U_36_U_U_1
  1.  ..;S X=$$CONC^BSTSAPI(IN)
  1.  ..S IN=SNO_"^^^1"
  1.  ..S X=$$CONC^AUPNSICD(IN)
  1.  ..S TXT=$P(X,U,4)
  1.  ..I $L(TXT) D APPEND(TXT_"-"_$P($P($G(^AUTTEDT(EDT,0)),U,1),"-",2))
  1.  .E  D APPEND($P($G(^AUTTEDT(EDT,0)),U))
  1.  .;D:EDT APPEND($P($G(^AUTTEDT(EDT,0)),U))
  1.  Q
  1. GET8 ;;Exams^;
  1.  N XAM
  1.  F  S LP=$O(^AUPNVXAM("AD",VIEN,LP)) Q:'LP  D
  1.  .S XAM=+$G(^AUPNVXAM(LP,0))
  1.  .D:XAM APPEND($P($G(^AUTTEXAM(XAM,0)),U))
  1.  Q
  1. GET9 ;;Health Factors^;
  1.  N HF
  1.  F  S LP=$O(^AUPNVHF("AD",VIEN,LP)) Q:'LP  D
  1.  .S HF=$P($G(^AUPNVHF(LP,0)),U)
  1.  .D:HF APPEND($P($G(^AUTTHF(HF,0)),U))
  1.  Q
  1. GET10 ;;Procedures^;
  1.  N PRC
  1.  F  S LP=$O(^AUPNVCPT("AD",VIEN,LP)) Q:'LP  D
  1.  .I PRV>0,$P($G(^AUPNVCPT(LP,12)),U,4)=PRV Q
  1.  .S PRC=$P($G(^AUPNVCPT(LP,0)),U)
  1.  .D:PRC APPEND($P($G(^ICPT(PRC,0)),U,2))
  1.  Q
  1. GET11 ;;Orders^
  1.  N ORLIST,LOC,X,Y,Z
  1.  K ^TMP("ORR",$J)
  1.  S LOC=$P(V0,U,22)_";SC("
  1.  D EN^ORQ1(DFN_";DPT(",,1,1,DAT,DAT,1)
  1.  Q:'$D(ORLIST)
  1.  F LP=0:0 S LP=$O(^TMP("ORR",$J,ORLIST,LP)) Q:'LP  D
  1.  .N ORD
  1.  .M ORD=^TMP("ORR",$J,ORLIST,LP)
  1.  .S Z=$G(^OR(100,+ORD,0))
  1.  .S Y=$P(Z,U,10)
  1.  .I 'Y,PRV>0,$P(Z,U,4)'=PRV Q
  1.  .I PRV>0,$P(Z,U,6)'=PRV Q
  1.  .I Y,LOC,Y'=LOC Q
  1.  .Q:$P(ORD,U,7)="canc"
  1.  .S Y=0
  1.  .F  S Y=$O(ORD("TX",Y)) Q:'Y  D APPEND(ORD("TX",Y))
  1.  .D ADDHDR
  1.  K ^TMP("ORR",$J)
  1.  Q
  1.  ; Round to 4 decimal points
  1.  ; Patch 5 change to 2 decimal places
  1. RND(X) Q $S(X=+X:+$J(X,0,2),1:X)
  1. ADDHDR S:CNT>0 @RET@(SCT,0)=U_CTL,CNT=0,SCT=SCT+1
  1.  Q
  1.  ; Append to result string
  1. APPEND(X,Y,Z) ;
  1.  S CNT=CNT+1,@RET@(SCT,CNT)=X_$S($L($G(Y)):" ("_Y_")",1:"")_$S($L($G(Z)):" ["_Z_"]",1:"")
  1.  Q