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

BEHOENP1.m

Go to the documentation of this file. 
  1. BEHOENP1 ;MSC/IND/DKM - Retrieve PCC data for a visit ;03-Jun-2014 12:24;DU
  1.  ;;1.1;BEH COMPONENTS;**005002,005004,005011,005012**;Sep 18, 2007
  1.  ;=================================================================
  1.  ; RPC: Return PCC data for an associated visit
  1. LOAD(DATA,DFN,VIEN) ;EP
  1.  N VSTR,LOC,VTYP,ICNT,ICOM,X0
  1.  Q:VIEN'>0
  1.  S VSTR=$$VIS2VSTR^BEHOENCX(DFN,VIEN)
  1.  Q:'$L(VSTR)
  1.  S VTYP=$P(VSTR,";",3),(ICNT,ICOM)=0
  1.  Q:VTYP="H"
  1.  ; Visit data
  1.  D ADD("HDR"_U_("ID"[VTYP)_U_U_VSTR)
  1.  S X0=^AUPNVSIT(VIEN,0),LOC=+$P(X0,U,22)
  1.  D ADD("VST^DT^"_$P(X0,U))
  1.  D ADD("VST^PT^"_$P(X0,U,5))
  1.  D ADD("VST^HL^"_LOC_"^^"_$P($G(^SC(LOC,0)),U))
  1.  D ADD("VST^PS^0")  ;outpt
  1.  D GET(9000010.06,"PRV")
  1.  D GET(9000010.07,"POV")
  1.  D GET(9000010.18,"CPT")
  1.  D GET(9000010.11,"IMM")
  1.  D GET(9000010.12,"SK")
  1.  D GET(9000010.16,"PED")
  1.  D GET(9000010.23,"HF")
  1.  D GET(9000010.13,"XAM")
  1.  D GET(9000010.15,"TRT")
  1.  D GET(9000010.01,"MSR")
  1.  D GET(120.5,"VIT")
  1.  Q
  1.  ; Fetch V File data
  1. GET(VF,TAG) ;
  1.  N LP,PC
  1.  S PC=$S(VF=120.5:3,1:1)
  1.  S VF=$$ROOT^DILFD(VF,,1)
  1.  Q:'$L(VF)
  1.  S LP=0
  1.  F  S LP=$O(@VF@("AD",VIEN,LP)) Q:'LP  D
  1.  .N X,CODE,CMNT,PRV,CAT
  1.  .M X=@VF@(LP)
  1.  .Q:$P(X(0),U,2)'=DFN
  1.  .S CODE=$P(X(0),U,PC),CMNT=$G(X(811)),PRV=$P($G(X(12)),U,4),CAT=$P($G(X(802)),U)
  1.  .S CAT=$S(CAT:$P(^AUTNPOV(CAT,0),U),1:"")
  1.  .D @TAG
  1.  Q
  1.  ; V PROVIDER
  1.  ; PRV^ien^^^name^primary/secondary flag
  1. PRV N NARR,PRIM
  1.  S NARR=$P($G(^VA(200,CODE,0)),U)
  1.  S PRIM=($P(X(0),U,4)="P")
  1.  D ADD(TAG_U_CODE_"^^^"_NARR_U_PRIM)
  1.  Q
  1.  ; V POV
  1.  ; POV^ien^CAT^narrative^com^prv^primary
  1. POV N NARR,PRIM,VDATE
  1.  ;IHS/MSC/MGH Changes for ICD-10 update
  1.  I CODE D
  1.  .S VDATE=$P($G(^AUPNVSIT(VIEN,0)),U,1)
  1.  .I $$AICD^BEHOENPC S CODE=$P($$ICDDX^ICDEX(CODE,VDATE),U,2)
  1.  .E  S CODE=$P($$ICDDX^ICDCODE(CODE,VDATE),U,2)
  1.  ;S CODE=$P(^ICD9(CODE,0),U)
  1.  ;S NARR=$P(X(0),U,4)
  1.  S NARR=$$GET1^DIQ(9000010.07,LP,.04)
  1.  I $P(NARR,"|",2)="" S NARR=$P(NARR,"|",1)
  1.  ;S:NARR NARR=$P(^AUTNPOV(NARR,0),U)
  1.  S PRIM=$P(X(0),U,12)="P"
  1.  D ADD(TAG_U_CODE_U_CAT_U_NARR_U_U_PRV_U_PRIM,CMNT)
  1.  Q
  1.  ; V CPT
  1.  ; CPT^ien^cat^nar^com^prv^qty^mods
  1. CPT N NARR,QTY,MCNT,MIDX,MODS,MIEN
  1.  S CODE=$O(^ICPT("B",CODE,0))
  1.  S:CODE CODE=$P(^ICPT(CODE,0),U)
  1.  S NARR=$P(X(0),U,4)
  1.  S:NARR NARR=$P(^AUTNPOV(NARR,0),U)
  1.  S QTY=$P(X(0),U,16)
  1.  S MCNT=0,MIDX=0,MODS=""
  1.  F  S MIDX=$O(X(1,MIDX)) Q:'MIDX  D
  1.  .S MIEN=X(1,MIDX,0)
  1.  .S:MIEN MCNT=MCNT+1,MODS=MODS_";/"_MIEN
  1.  S:MCNT MODS=MCNT_MODS
  1.  D ADD(TAG_U_CODE_U_CAT_U_NARR_U_U_PRV_U_QTY_U_MODS,CMNT)
  1.  Q
  1.  ; V IMMUNIZATION
  1.  ; IMM^ien^cat^nar^com^prv^Series^Reaction^Contraindicated^Refused^LotNum^Site^Volume^VISDate
  1. IMM N NARR,QTY,REF
  1.  S:CODE NARR=$P(^AUTTIMM(CODE,0),U)
  1.  S QTY=$P(X(0),U,4)
  1.  S REF=$$REFUSAL(9999999.14,CODE,LP)
  1.  D ADD(TAG_U_CODE_U_CAT_U_NARR_U_U_PRV_U_QTY_U_$P(X(0),U,6)_U_$P(X(0),U,7)_U_REF_U_$P(X(0),U,5)_U_$P(X(0),U,9)_U_$P(X(0),U,11)_U_$P(X(0),U,12),CMNT)
  1.  Q
  1.  ; V SKIN TEST
  1.  ; SK^ien^cat^nar^com^prv^Result^Reading^D/T read^D/T given^Read by^Refused
  1. SK N NARR,QTY,REF
  1.  S:CODE NARR=$P(^AUTTSK(CODE,0),U)
  1.  S QTY=$P(X(0),U,4)
  1.  S REF=$$REFUSAL(9999999.28,CODE,LP)
  1.  ;IHS/MSC/MGH added $G for missing entry date/time
  1.  D ADD(TAG_U_CODE_U_CAT_U_NARR_U_U_PRV_U_QTY_U_$P(X(0),U,5)_U_$P(X(0),U,6)_U_$P($G(X(12)),U)_U_$P(X(0),U,8)_U_REF,CMNT)
  1.  Q
  1.  ; V PATIENT ED
  1.  ; PED^ien^cat^nar^com^prv^Level of understanding^Refused^Elapsed^Setting^Goals^Outcome
  1. PED N NARR,QTY,REF,SNO,Z,TXT,IN
  1.  Q:'CODE
  1.  S NARR=$P(^AUTTEDT(CODE,0),U)
  1.  ;IHS/MSC/MGH Updated for SNOMED education
  1.  I $P($G(^AUTTEDT(CODE,0)),U,12)'="" D
  1.  .S TXT=""
  1.  .S SNO=$P($G(^AUTTEDT(CODE,0)),U,12)
  1.  .S IN=SNO_U_36_U_U_1
  1.  .S Z=$$CONC^BSTSAPI(IN)
  1.  .S TXT=$P(Z,U,4)
  1.  .I $L(TXT) S NARR=TXT_"-"_$P($P($G(^AUTTEDT(CODE,0)),U,1),"-",2)
  1.  S QTY=$P(X(0),U,6)
  1.  S REF=$$REFUSAL(9999999.09,CODE,LP)
  1.  D ADD(TAG_U_CODE_U_CAT_U_NARR_U_U_PRV_U_QTY_U_REF_U_$P(X(0),U,8)_U_$P(X(0),U,7)_U_$P(X(0),U,13)_U_$P(X(0),U,14),CMNT)
  1.  Q
  1.  ; V HEALTH FACTOR
  1.  ; HF^ien^cat^nar^com^prv^Level/severity
  1. HF N NARR,QTY
  1.  S:CODE NARR=$P(^AUTTHF(CODE,0),U)
  1.  S QTY=$P(X(0),U,4)
  1.  D ADD(TAG_U_CODE_U_CAT_U_NARR_U_U_PRV_U_QTY,CMNT)
  1.  Q
  1.  ; V EXAM
  1.  ; XAM^ien^cat^nar^com^prv^Result^Refused
  1. XAM N NARR,QTY,REF
  1.  S:CODE NARR=$P(^AUTTEXAM(CODE,0),U)
  1.  S QTY=$P(X(0),U,4)
  1.  S REF=$$REFUSAL(9999999.15,CODE,LP)
  1.  D ADD(TAG_U_CODE_U_CAT_U_NARR_U_U_PRV_U_QTY_U_REF,CMNT)
  1.  Q
  1.  ; V TREATMENT
  1.  ; TRT^ien^cat^nar^com^prv^qty
  1. TRT N QTY,NARR
  1.  S QTY=$P(X(0),U,4)
  1.  S NARR=$P(X(0),U,6)
  1.  S:NARR NARR=$P(^AUTNPOV(NARR,0),U)
  1.  D ADD(TAG_U_CODE_U_CAT_U_NARR_U_U_PRV_U_QTY,CMNT)
  1.  Q
  1.  ; V MEASUREMENT
  1. MSR N NARR,VAL,EIE
  1.  S:CODE NARR=$P(^AUTTMSR(CODE,0),U)
  1.  S VAL=$P(X(0),U,4)
  1.  S EIE=$P($G(X(2)),U,1)
  1.  Q:EIE=1
  1.  D ADD(TAG_U_CODE_U_CAT_U_$G(NARR)_U_U_PRV_U_VAL)
  1.  Q
  1.  ; GMRV VITAL MEASUREMENT
  1. VIT N NARR,VAL
  1.  S:CODE NARR=$P(^GMRD(120.51,CODE,0),U,7)
  1.  S VAL=$P(X(0),U,8)
  1.  D ADD("MSR^"_CODE_U_CAT_U_$G(NARR)_U_U_PRV_U_VAL)
  1.  Q
  1.  ; Add to return array
  1. ADD(X,C) S:$L($G(C)) ICOM=ICOM+1,$P(X,U,5)=ICOM
  1.  S ICNT=ICNT+1,@DATA@(ICNT)=X
  1.  D:$L($G(C)) ADD("COM"_U_ICOM_U_C)
  1.  Q
  1.  ; Look for a refusal of specified type
  1.  ;  FNUM = File # of PCC type file
  1.  ;  CODE = IEN in PCC type file
  1.  ;  VISIT= IEN in visit file
  1.  ; .IEN  = Returned IEN of entry in refusal file (or 0 if none)
  1.  ;  Returns internal value of refusal reason or null
  1. REFUSAL(FNUM,CODE,VISIT,IEN) ;EP
  1.  N DAT,DFN,X
  1.  S X=$G(^AUPNVSIT(VISIT,0)),DAT=X\1,DFN=$P(X,U,5),IEN=0
  1.  I FNUM,CODE,DAT,DFN D
  1.  .S IEN=$O(^AUPNPREF("AA",DFN,FNUM,CODE,9999999-DAT,0))
  1.  Q:$Q $S(IEN:$P($G(^AUPNPREF(IEN,0)),U,7),1:"")
  1.  Q
  1.  ; RPC: Return the default values for an immunization
  1.  ;  IMM = IEN in IMMUNIZATION file
  1.  ;  Returns:
  1.  ;    VIS Date^Volume^Lot #
  1. IMMDFLTS(DATA,IMM) ;EP
  1.  N X,VOL
  1.  S X=$G(^AUTTIMM(+$G(IMM),0))
  1.  S $P(DATA,U)=$P(X,U,13)
  1.  ;S $P(DATA,U,2)=$P(X,U,18)
  1.  ;IHS/MSC/MGH modified to add leading zeros
  1.  S VOL=$P(X,U,18) I $E(VOL,1,1)="." S VOL="0"_VOL
  1.  S $P(DATA,U,2)=VOL
  1.  S $P(DATA,U,3)=$$GET1^DIQ(9999999.41,+$P(X,U,4),.01)
  1.  Q
  1.  ; Lot # screen
  1. IMMLOTSC(LOT,IMM) ;EP
  1.  N X,I
  1.  S X=$G(^AUTTIML(+LOT,0))
  1.  Q:'$L(X)!$P(X,U,3) 0
  1.  F I=4:1:8 I $P(X,U,I)=IMM S I=-1 Q
  1.  ;IHS/MSC/MGH P14 Facility specific lot
  1.  Q:(($P(X,U,14))&($P(X,U,14)'=$G(DUZ(2)))) 0
  1.  Q $S(I=-1:1,1:0)
  1.  ;Elig screen
  1. IMMELIG(CODE) ;EP
  1.  N X
  1.  S X=$G(^BIELIG(CODE,0))
  1.  Q '$P(X,U,3)