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

BGOSNLK.m

Go to the documentation of this file. 
  1. BGOSNLK ; IHS/MSC/MGH - SNOMED Picklists ;05-Dec-2014 07:22;du
  1.  ;;1.1;BGO COMPONENTS;**13,14**;Mar 20, 2007;Build 1
  1.  ;Input is the name of the picklist
  1. GETLST(RET,INP) ;Return items from a SNOMED picklist
  1.  N FNUM,GRP,PICK,ITM,SNO,DESC,TXT,STAT,CNT,IN,OUT,X,DATA,ICD
  1.  S RET=$$TMPGBL^BGOUTL
  1.  S CNT=0
  1.  S FNUM=90362.34
  1.  S PICK="" S PICK=$O(^BGOSNOPR("B",INP,PICK))
  1.  Q:PICK=""
  1.  S ITM=0 F  S ITM=$O(^BGOSNOPR(PICK,1,ITM)) Q:'+ITM  D
  1.  .S DATA=$G(^BGOSNOPR(PICK,1,ITM,0))
  1.  .S SNO=$P(DATA,U,1)
  1.  .S DESC=$P(DATA,U,2)
  1.  .S STAT=$P(DATA,U,6)
  1.  .S ICD=""
  1.  .S GRP=$P($G(^BGOSNOPR(PICK,1,ITM,1)),U,2)
  1.  .;look it up in Apelon
  1.  .;changed to use new API
  1.  .;S X=$$CONC^BSTSAPI(SNO_"^36^^1")
  1.  .S X=$$CONC^AUPNSICD(SNO_"^^^1")
  1.  .I $P(X,U,1)'="" D
  1.  ..S DESC=$P(X,U,3)
  1.  ..S TXT=$P(X,U,4)
  1.  ..S ICD=$P(X,U,5)
  1.  .S CNT=CNT+1
  1.  .S @RET@(CNT)=TXT_U_DESC_U_SNO_U_ICD_U_STAT_U_GRP
  1.  Q
  1. SUBSET(RET,INP) ;Return data from a subset
  1.  N CNT,SUBSET,IN,OUT,X,SNO,ICD,DESC,TXT
  1.  S CNT=0
  1.  I $G(RET)="" S RET=$$TMPGBL^BGOUTL
  1.  ;look it up in Apelon
  1.  S OUT=$$SNOTMP
  1.  S IN=INP_"^^1"
  1.  S X=$$SUBLST^BSTSAPI(.OUT,.IN)
  1.  ;1 means success
  1.  I X>0 D
  1.  .S CNT="" F  S CNT=$O(@OUT@(CNT)) Q:CNT=""  D
  1.  ..S ICD=""
  1.  ..S NODE=$G(@OUT@(CNT))
  1.  ..S SNO=$P(NODE,U,1)
  1.  ..;IHS/MSC/MGH changed to use new api
  1.  ..;S X=$$CONC^BSTSAPI(SNO_"^36^^1")
  1.  ..S X=$$CONC^AUPNSICD(SNO_"^^^1")
  1.  ..I X'="" S ICD=$P($P(X,U,5),";",1)
  1.  ..S DESC=$P(NODE,U,2),TXT=$P(NODE,U,3)
  1.  ..S @RET@(CNT)=TXT_U_DESC_U_SNO_U_ICD_U_""_U_TXT
  1.  Q
  1. SNOTMP() K ^TMP("BGOSN"_$G(X),$J) Q $NA(^($J))
  1.  ;
  1. UPDATE() ;Update picklists from Apelon
  1.  N X,ARR,I,RET
  1.  S X=$$SUBSET^BSTSAPI("ARR")
  1.  S I=0 F  S I=$O(ARR(I)) Q:I=""  D
  1.  .S NAME=$G(ARR(I))
  1.  .I $E(NAME,1,4)="PICK" D
  1.  ..S IEN="" S IEN=$O(^BGOSNOPR("SS",$E(NAME,1,30),IEN))
  1.  ..I IEN="" D
  1.  ...S PICK=$E(NAME,6,$L(NAME))
  1.  ...;S PICK=$$UPPER(PICK)
  1.  ...S IEN=$$NEW(NAME,PICK)
  1.  ..Q:IEN=""
  1.  ..S PICK=$P($G(^BGOSNOPR(IEN,0)),U,1)
  1.  ..W !,"Updating "_PICK
  1.  ..D IMPORT(.RET,NAME,PICK)
  1.  ..I $$UPPER($E(PICK,1,8))="PRENATAL" D
  1.  ...N IENS,FDA,ERR
  1.  ...S IENS=IEN_","
  1.  ...S FDA(90362.34,IENS,.09)=1
  1.  ...D UPDATE^DIE(,"FDA","","ERR")
  1.  ..S INP=IEN_U_DUZ_U_1
  1.  ..D SETMGR^BGOSNOPR(.RET,INP)
  1.  Q
  1.  ;Import data from an Apelon subset to a SNOMED picklist
  1.  ;Input parameters
  1.  ;1)The Apelon subset
  1.  ;2)The name of the SNOMED picklist
  1. IMPORT(RET,SUBSET,INP) ;EP
  1.  N PICK,OUT,IN,X,NODE,CK,SNO,AIEN,FNUM,FDA,IEN,ERR,NEW
  1.  S NEW=0
  1.  S PICK="" S PICK=$O(^BGOSNOPR("B",INP,PICK))
  1.  I PICK="" S NEW=1 S PICK=$$NEW(SUBSET,INP)
  1.  Q:PICK<1
  1.  S OUT=$$SNOTMP
  1.  S IN=SUBSET
  1.  S X=$$SUBLST^BSTSAPI(.OUT,.IN)
  1.  ;1 means success
  1.  I X>0 D
  1.  .S CNT="" F  S CNT=$O(@OUT@(CNT)) Q:CNT=""  D
  1.  ..S NODE=$G(@OUT@(CNT))
  1.  ..S SNO=$P(NODE,U,1)
  1.  ..;Don't load again if its already there
  1.  ..S CK=$O(^BGOSNOPR(PICK,1,"B",SNO,""))
  1.  ..Q:+CK
  1.  ..N FDA,IEN,ERR
  1.  ..S AIEN="+1,"_PICK_","
  1.  ..S FDA(90362.342,AIEN,.01)=SNO
  1.  ..S FDA(90362.342,AIEN,.02)=$P(NODE,U,2)
  1.  ..S FDA(90362.342,AIEN,.03)=0
  1.  ..S FDA(90362.342,AIEN,6)=$P(NODE,U,3)
  1.  ..D UPDATE^DIE(,"FDA","IEN","ERR")
  1.  ..I '$D(ERR) S RET=IEN(1)
  1.  ..E  S RET=RET_"-1^Error adding item"_SNO
  1.  .S INP=PICK_U_DUZ_U_1
  1.  .D SETMGR^BGOSNOPR(.RET,INP)
  1.  I NEW S RET=PICK
  1.  E  S RET="-"_PICK
  1.  Q
  1. NEW(SUBSET,NAME) ;Create a new picklist
  1.  N IEN,FDA,DIR,RET
  1.  S IEN="+1,"
  1.  S FDA(90362.34,IEN,.01)=NAME
  1.  S FDA(90362.34,IEN,.08)=SUBSET
  1.  S FDA(90362.34,IEN,.05)=DUZ
  1.  D UPDATE^DIE(,"FDA","IEN","ERR")
  1.  I $D(ERR) S RET=-1
  1.  E  S RET=IEN(1)
  1.  I RET>0 D
  1.  .N INP,RET1
  1.  .S INP=RET_U_DUZ_U_1
  1.  .D SETMGR^BGOSNOPR(.RET1,INP)
  1.  Q RET
  1. CONCLKUP(RET,CONCID) ;EP
  1.  ;Changed to use new api
  1.  S CONCID=$G(CONCID)_"^^^1"
  1.  S RET=$$CONC^AUPNSICD(CONCID)
  1.  Q
  1. GETSUB(RET,PREFIX) ;Return list of subsets to select from
  1.  N X,ARR,I,CNT
  1.  S RET=$$TMPGBL^BGOUTL
  1.  S PREFIX=$S($G(PREFIX)="":"PICK",1:$G(PREFIX))
  1.  S CNT=0
  1.  S X=$$SUBSET^BSTSAPI("ARR","36^1")
  1.  S I=0 F  S I=$O(ARR(I)) Q:I=""  D
  1.  .S NAME=$G(ARR(I))
  1.  .I $E(NAME,1,4)=PREFIX D
  1.  ..S CNT=CNT+1
  1.  ..S @RET@(CNT)=$G(ARR(I))
  1.  Q
  1. TREAT(RET,VIEN) ;Find all the treatment/regimens
  1.  N FNUM,GRP,SUB,ARR,X,GRP,ITM,CNT,IN,OUT,X,VDT,FCNT
  1.  S RET=$$TMPGBL^BGOUTL
  1.  S SUB="TREG "
  1.  S X=$$SUBSET^BSTSAPI("ARR","36^1")
  1.  Q:X=0
  1.  S CNT=0,FCNT=0
  1.  S VDT=$$GET1^DIQ(9000010,VIEN,.01,"I")
  1.  F  S CNT=$O(ARR(CNT)) Q:CNT=""  D
  1.  .S NAME=$G(ARR(CNT))
  1.  .I $E(NAME,1,4)="TREG" D
  1.  ..S GRP=$E(NAME,6,$L(NAME))
  1.  ..D DATA(NAME,GRP,VDT)
  1.  Q
  1. DATA(NAME,GRP,VDT) ;Get the subset data
  1.  N OUT,IN,X,Y,TXT,DESC,SNO,ICD,NODE,NUM
  1.  S OUT=$$SNOTMP
  1.  S IN=NAME_"^^1"
  1.  S X=$$SUBLST^BSTSAPI(.OUT,.IN)
  1.  ;1 means success
  1.  I X>0 D
  1.  .S NUM="" F  S NUM=$O(@OUT@(NUM)) Q:NUM=""  D
  1.  ..S NODE=$G(@OUT@(NUM))
  1.  ..S SNO=$P(NODE,U,1)
  1.  ..S DESC=$P(NODE,U,2)
  1.  ..S TXT=$P(NODE,U,3)
  1.  ..;IHS/MSC/MGH changed to use new API
  1.  ..;S Y=$$CONC^BSTSAPI(SNO_"^^"_VDT_"^1")
  1.  ..S Y=$$CONC^AUPNSICD(SNO_"^^"_VDT_"^1")
  1.  ..I Y'="" S ICD=$P($P(Y,U,5),";",1)
  1.  ..S FCNT=FCNT+1
  1.  ..S @RET@(FCNT)=TXT_U_DESC_U_SNO_U_ICD_U_U_GRP
  1.  Q
  1. UPPER(X) ;Turn value to upper case
  1.  Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")