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

BGOVPED2.m

Go to the documentation of this file. 
  1. BGOVPED2 ; IHS/BAO/TMD - Patient Education ;04-Apr-2016 08:54;du
  1.  ;;1.1;BGO COMPONENTS;**8,13,14,20**;Mar 20, 2007
  1.  ;---------------------------------------------
  1.  ;  Return IEN of code given the name
  1.  ;  INP = Name of code
  1.  ;  TYPE=ICD or SNOMED
  1.  ;RET=IEN of code in patient education file
  1. FIND(RET,INP) ;EP
  1.  N MAJOR,TYPE,CODE,IEN,ABB,LOOKUP,CTYPE
  1.  S MAJOR=$P(INP,"-",1),TYPE=$P($P(INP,"-",2),U)
  1.  S CTYPE=$P(INP,U,2)
  1.  S CODE=0
  1.  ;Patch 20 changed lookup
  1.  I +MAJOR!($E(MAJOR,1,1)="V")!(CTYPE="ICD") D
  1.  .S CODE=$$LOOK($P(INP,U,1))
  1.  .;Try a second time with upper case
  1.  .I CODE=0 D
  1.  ..S INP=$$UPPER(INP)
  1.  ..S CODE=$$LOOK($P(INP,U,1))
  1.  .I CODE=0 S CODE=$$CREATE(MAJOR,TYPE)
  1.  E  D
  1.  .S MAJOR=$$UPPER(MAJOR)
  1.  .S IEN=$O(^AUTTEDMT("B",MAJOR,"")) Q:IEN=""  D
  1.  ..S ABB=$P($G(^AUTTEDMT(IEN,0)),U,2)
  1.  ..S LOOKUP=ABB_"-"_$$UPPER(TYPE)
  1.  ..S CODE=$$LOOK(LOOKUP)
  1.  ..I CODE=0 D
  1.  ...S LOOKUP=ABB_"-"_TYPE
  1.  ...S CODE=$$LOOK(LOOKUP)
  1.  I CODE=0 D CREATE(MAJOR,$$UPPER(TYPE))
  1.  S RET=CODE
  1.  Q
  1. LOOK(NAME) ;Check for the code
  1.  N EDU,GOOD,IEN
  1.  S GOOD=0,IEN=0
  1.  S EDU="" F  S EDU=$O(^AUTTEDT("B",NAME,EDU)) Q:EDU=""!(+GOOD)  D
  1.  .I $P($G(^AUTTEDT(EDU,0)),U,3)="" S GOOD=1,IEN=EDU
  1.  Q IEN
  1. CREATE(ICD,TOPIC) ;Add this ICD9 related code to the database
  1.  N ED,INP,RET,IEN,DATA,TIEN
  1.  S ED=0,IEN="",TIEN=""
  1.  I CTYPE="ICD" D
  1.  .;S INP=ICD_U_"1^^^0"
  1.  .;D ICDLKUP^BGOICDLK(.RET,INP)
  1.  .I $$AICD^BGOUTL2 D
  1.  ..S X=$$ICDDX^ICDEX(ICD,$$NOW^XLFDT)
  1.  ..S IEN=$P(X,U,1)
  1.  .E  D
  1.  ..S X=$$ICDDX^ICDCODE(ICD,$$NOW^XLFDT)
  1.  ..S IEN=$P(X,U,1)
  1.  ..;I '$D(@RET@(1)) S DATA="" Q
  1.  ..;S DATA=@RET@(1)
  1.  ..;S IEN=$P(DATA,U,2)
  1.  E  S IEN=ICD
  1.  S TOPIC=$$UPPER(TOPIC)
  1.  S TIEN=$O(^APCDEDCV("B",TOPIC,TIEN))
  1.  I +IEN&(+TIEN) D
  1.  .S INP=IEN_U_TIEN
  1.  .I CTYPE="ICD" D SETDXTOP^BGOVPED(.RET,INP,1)
  1.  .E  D SETSNTOP^BGOVPED(.RET,INP)
  1.  .S ED=$P(RET,U,1)
  1.  Q ED
  1. UPPER(X) ; Convert lower case X to UPPER CASE
  1.  Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1.  ;-----------------------------------------------------------------
  1.  ; Send and store an array of patient educations for a patient and a vis
  1.  ; Input parameter
  1.  ;  PT=DFN [1] ^ VIEN [2]
  1.  ;  INP=COMPREHENSION [1] ^ LENGTH [2] ^ READINESS [3] ^ NUMBER [4]
  1.  ;  EDU(ARRAY) = PROB IEN [1] ^ SNOMED CONCEPT CT [2] ^ TOPIC [3] ^ IEN [4]
  1.  ; Output string
  1.  ;  IENs stored separated by ^
  1. PROBEDU(RET,PT,INP,EDU) ;EP
  1.  N VIEN,DFN,COMP,LEN,NUM,READ,ICHK,SNO,TOPIC,TOPIEN,TOPID,INPST,DATA,LOC,EIEN
  1.  S DFN=$P(PT,U,1),VIEN=$P(PT,U,2),EIEN=""
  1.  S RET="",TOPIEN=""
  1.  I 'DFN!('VIEN) S RET="-1^Patient or visit not defined" Q
  1.  S NUM=$P(INP,U,4)
  1.  S LEN=$P(INP,U,2)
  1.  I LEN=0 S LEN=""
  1.  I +LEN>0 S LEN=LEN\NUM
  1.  S LOC=$P($G(^AUPNVSIT(VIEN,0)),U,22)
  1.  S COMP=$P(INP,U,1),READY=$P(INP,U,3)
  1.  S ICHK="" F  S ICHK=$O(EDU(ICHK)) Q:ICHK=""  D
  1.  .S PROB=$P(EDU(ICHK),U,1)
  1.  .S SNO=$P(EDU(ICHK),U,2)
  1.  .S TOPIC=$P(EDU(ICHK),U,3)
  1.  .S EIEN=$P(EDU(ICHK),U,4)
  1.  .I SNO=""!(TOPIC="") S RET=RET_U_"-1^Snomed education not defined" Q
  1.  .S TOPIC=$$UPPER(TOPIC)
  1.  .S TOPID=$O(^APCDEDCV("B",TOPIC,""))
  1.  .I TOPID="" S TOPID=$O(^APCDEDCV("C",TOPIC,""))
  1.  .I TOPID="" S RET=RET_U_"-1^Topic not identified" Q
  1.  .D SETSNTOP^BGOVPED(.TOPIEN,SNO_U_TOPID)
  1.  .I TOPIEN="" S RET=RET_U_"-1^Unable to store education topic" Q
  1.  .S INPST=EIEN_U_$P(TOPIEN,U,1)_U_DFN_U_VIEN_U_DUZ_U_COMP_U_"I"_U_LEN_U_U_U_U_U_U_LOC_U_U_U_READY_U_U_PROB
  1.  .S DATA=""
  1.  .D SET^BGOVPED(.DATA,INPST)
  1.  .I RET="" S RET=DATA
  1.  .E  S RET=RET_U_DATA
  1.  Q
  1.  ;
  1.  ;Convert the convoluted array returned by CLININD^ORWDXIHS to a numerically indexed one
  1.  ; that's easy for VB6 to handle.
  1. GETPROBS(RET,INP) ; EP
  1.  N CNT,CR,VAR,DFN,VIEN,OID,SNOMED
  1.  S INP=$G(INP)
  1.  S DFN=$P(INP,U,1),VIEN=$P(INP,U,2),OID=$P(INP,U,3),SNOMED=$P(INP,U,4)
  1.  D CLININD^ORWDXIHS(.CR,DFN,VIEN,OID,SNOMED) ; Pass along whatever we got (or didn't get)
  1.  S RET=$$TMPGBL^BGOUTL
  1.  S VAR="CR",CNT=0
  1.  I $D(@VAR)#10 S @RET@(CNT)=@VAR ; Put any scalar value in the first (zero) node
  1.  F  S VAR=$Q(@VAR) Q:VAR=""  S CNT=CNT+1,@RET@(CNT)=@VAR
  1.  Q
  1.  ;Input=VIEN
  1.  ;Output=Array
  1.  ;Format= Problem IEN [1] ^ Topic [2] ^ Date enered [3] ^Provider IEN [4] ^ Provider Name [5] ^ VPED IEN [6]
  1.  ;CODE[7] ^ TYPE [8] ^ LEVEL [9] ^ TIME [10] ^READINESS [11] ^ Mnemonic [12]
  1. GETPVED(RET,VIEN) ;Get visit education for problems
  1.  N PROB,EIEN,TOPIC,CDATE,EPRV,PRVNAME,CNT,CODE,TXT,PIEN,LEVEL,TIME,READY,TOPICIEN,MN
  1.  I $G(RET)="" S RET=$$TMPGBL
  1.  S CNT=0
  1.  S EIEN="" F  S EIEN=$O(^AUPNVPED("AD",VIEN,EIEN)) Q:EIEN=""  D
  1.  .S PROB=$$GET1^DIQ(9000010.16,EIEN,1103,"I")
  1.  .Q:PROB=""
  1.  .S TOPIC=$$GET1^DIQ(9000010.16,EIEN,.01)
  1.  .S TOPICIEN=$$GET1^DIQ(9000010.16,EIEN,.01,"I")
  1.  .S PIEN=$$GET1^DIQ(9000010.16,EIEN,.01,"I")
  1.  .S CDATE=$$GET1^DIQ(9000010.16,EIEN,1201,"I")
  1.  .S CDATE=$$FMTDATE^BGOUTL(CDATE)
  1.  .S EPRV=$$GET1^DIQ(9000010.16,EIEN,1204,"I")
  1.  .S PRVNAME=$$GET1^DIQ(9000010.16,EIEN,1204)
  1.  .S CODE=$P($G(^AUTTEDT(PIEN,0)),U,1)
  1.  .S TXT=$P(CODE,"-",2),CODE=$P(CODE,"-",1)
  1.  .S LEVEL=$$GET1^DIQ(9000010.16,EIEN,.06)
  1.  .S TIME=$$GET1^DIQ(9000010.16,EIEN,.08)
  1.  .S READY=$$GET1^DIQ(9000010.16,EIEN,1102)
  1.  .S MN=$$GET1^DIQ(9999999.09,TOPICIEN,1)
  1.  .S CNT=CNT+1
  1.  .S @RET@(CNT)=PROB_U_TOPIC_U_CDATE_U_EPRV_U_PRVNAME_U_EIEN_U_CODE_U_TXT_U_LEVEL_U_TIME_U_READY_U_MN
  1.  Q
  1. TOPIC(RET) ;Return list of education topics with mnenomics
  1.  N CNT,PARAM,ENT,FMT,USR,ERR,TMP,TXT,MN
  1.  S CNT=0
  1.  S RET=$$TMPGBL
  1.  S PARAM="BGO PROBLEM EDUCATION",ENT="ALL",FMT="B"
  1.  D GETLST^XPAR(.TMP,$$ENT^CIAVMRPC(PARAM,.ENT,.USR),PARAM,.FMT,.ERR)
  1.  F  S CNT=$O(TMP(CNT)) Q:CNT=""  D
  1.  .S IEN=$P($G(TMP(CNT,"V")),U,1)
  1.  .S TXT=$P($G(TMP(CNT,"V")),U,2)
  1.  .S MN=$$GET1^DIQ(9001002.5,IEN,.02)
  1.  .S @RET@(CNT)=CNT_U_TXT_U_MN
  1.  Q
  1. TMPGBL(X) ;EP
  1.  K ^TMP("BGOVPED",$J) Q $NA(^($J))