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

BEHOORSY.m

Go to the documentation of this file. 
  1. BEHOORSY ; IHS/MSC/MGH Sign or Symptom ;27-Oct-2015 10:28;PLS
  1.  ;;1.1;BEH COMPONENTS;**011006,011007,011008**;Sep 18, 2007;Build 1
  1.  ;
  1.  ;
  1. GETDIAG ; EP
  1.  ; User MUST enter a diagnosis.  No exceptions.
  1.  N DIR,SNOMED,IN,OUT,ITEM,DA,SNO,XSAVE,LINE,LINEVAR,NUM,ICDCODE
  1.  N SNOMED,SNOMEDSC,VARS,VARSDESC,WHICHONE
  1.  ;S Y=0
  1.  ;F  Q:Y  D
  1.  ;. W !!
  1.  ;. D ^XBFMK
  1.  ;. S DIR(0)="F"
  1.  ;. S DIR("A")="Enter Clinical Indication (Free Text)"
  1.  ;. D ^DIR
  1.  ;. I $L(X)<1!(+$G(DIRUT))!(X["^") S Y=9999999 Q
  1.  S XSAVE=X
  1.  K OUT  S OUT="VARS",IN=$G(X)_"^F",$P(IN,"^",6)=100,$P(IN,"^",8)=1,$P(IN,"^",11)=1
  1.  S SNO=$$SEARCH^BSTSAPI(OUT,IN)
  1.  I SNO<1 W !!,?9,"No entries found in the IHS STANDARD TERMINOLOGY database."
  1.  I SNO>0&(SNO'=9999999) D
  1.  .S SNOMED=$$LISTMSEL()
  1.  .S Y=$P(SNOMED,U,1)
  1.  .S X=$P(SNOMED,U,1)
  1.  Q
  1. POST(Y) ;   Set the dialogs
  1.  N SNO
  1.  S SNO=$$DESC^BSTSAPI(Y)
  1.  S ORDIALOG($$PTR("CLININD"),1)=$P(SNO,U,2)
  1.  S ORDIALOG($$PTR("SNMDCNPTID"),1)=$P(SNO,U,1)
  1.  S ORDIALOG($$PTR("CLININD2"),1)=$P($P(SNO,U,3),";")
  1.  Q
  1. CHKDEL(Y) ;EP Check for deletion
  1.  I +Y=0 S ORDIALOG($$PTR("SNMDCNPTID"),1)=""
  1.  Q
  1.  ;
  1. PTR(X) ; -- Ptr to prompt OR GTX X
  1.  Q +$O(^ORD(101.41,"AB","OR GTX "_X,0))
  1.  ;
  1. LISTMSEL() ; EP - LIST Manager to SELect entry
  1.  K SNOMED
  1.  S WHICHONE=0
  1.  D EN^BEHOORSM(1)
  1.  Q $G(SNOMED(WHICHONE))
  1. QUIT ; EP -
  1.  ;
  1.  D CLEAR^VALM1
  1.  K SNOMED,DA
  1.  Q
  1. CHK() ;EP -See what its doing
  1.  I $G(ORDIALOG($$PTR("CLININD"),1))="" D
  1.  .S ORDIALOG($$PTR("SNMDCNPTID"),1)=""
  1.  Q
  1. ID() ;Set CLININD2
  1.  N CLIN,ID
  1.  S CLIND=$$PTR("CLININD2")
  1.  S ID=$G(ORDIALOG(CLIND,1))
  1.  Q ID
  1. QUICK ;Report to find quick orders with clinical indications that are not converted to SNOMED
  1.  N ZTRTN
  1.  W @IOF
  1.  W !,"Unconverted Quick Order to SNOMED clinical indication report",!!
  1.  S ZTRTN="OUT^BEHOORSY"
  1.  D DEVICE
  1.  Q
  1. DEVICE ; Device handling
  1.  ; Call with: ZTRTN
  1.  N %ZIS
  1.  S %ZIS="Q" D ^%ZIS Q:POP
  1.  G:$D(IO("Q")) QUE
  1. NOQUE ; Call report directly
  1.  D @ZTRTN
  1.  Q
  1. QUE ; Queue output
  1.  N %,ZTDTH,ZTIO,ZTSAVE,ZTSK
  1.  Q:'$D(ZTRTN)
  1.  K IO("Q") S ZTSAVE("BGORPT")=""
  1.  S:'$D(ZTDESC) ZTDESC="Unconverted Clinical Indication to SNOMED report" S ZTIO=ION
  1.  D ^%ZTLOAD W !,$S($D(ZTSK):"Request Queued!",1:"Request Cancelled!")
  1.  K ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
  1.  D HOME^%ZIS
  1.  Q
  1. OUT ;Run the report
  1.  N I,J,NAME,TYPE,ITEM,CVALUE,SVALUE,CLININD,SNOMED,NAME
  1.  D HDR
  1.  S (CLININD,SNOMED)=""
  1.  S CLININD=$O(^ORD(101.41,"B","OR GTX CLININD",""))
  1.  S SNOMED=$O(^ORD(101.41,"B","OR GTX SNMDCNPTID",""))
  1.  S I=0 F  S I=$O(^ORD(101.41,I)) Q:'+I  D
  1.  .S TYPE=$P($G(^ORD(101.41,I,0)),U,4)
  1.  .Q:TYPE'="Q"
  1.  .S (CVALUE,SVALUE)=""
  1.  .S J=0 F  S J=$O(^ORD(101.41,I,6,J)) Q:'+J  D
  1.  ..S ITEM=$P($G(^ORD(101.41,I,6,J,0)),U,2)
  1.  ..I ITEM=CLININD D
  1.  ...S CVALUE=$G(^ORD(101.41,I,6,J,1))
  1.  ..I ITEM=SNOMED D
  1.  ...S SVALUE=$G(^ORD(101.41,I,6,J,1))
  1.  .I CVALUE'=""&(SVALUE="") D
  1.  ..S NAME=$P($G(^ORD(101.41,I,0)),U,1)
  1.  ..W !,NAME,?40,CVALUE
  1.  Q
  1. HDR(TYP) ;PRINT HEADER
  1.  N LIN,DTYP
  1.  I IOST["C-" W @IOF
  1.  W !,"Unconverted Clinical Indication to SNOMED report",!
  1.  W !,"Order Dialog",?40,"Clinical Indication"
  1.  W ! F LIN=1:1:72 W "-"
  1.  W !
  1.  Q