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

PXRMSTA1.m

Go to the documentation of this file. 
  1. PXRMSTA1 ; SLC/AGP - Routines for building status list. ;05/08/2014
  1.  ;;2.0;CLINICAL REMINDERS;**4,6,26**;Feb 04, 2005;Build 404
  1.  ;
  1.  ;This routine and PXRMSTA2 allows users to select the
  1.  ;approriate status for Orders, Medication, Taxonomy, Problem List,
  1.  ;and Radiology Procedure findings items.
  1.  ;
  1. ADD(GBL,FILE,CSTATUS,TYPE,WILD,DA,UPDATE) ;
  1.  N ANS,STATUS,TERMIEN
  1.  ;Find what types of finding are in the term
  1.  I TYPE["PXRMD(811.5," D
  1.  .S TERMIEN=$P($G(TYPE),";")
  1.  .S TYPE=$$TERMSTAT(TERMIEN) I TYPE=0 Q
  1.  .I TYPE["PXD" S TAXTYPE=$$TAXTYPE(TERMIEN,"")
  1.  I TYPE=0 Q
  1.  ;Find out what is in the taxonomy
  1.  I TYPE["PXD(811.2,",$G(TAXTYPE)="" S TAXTYPE=$$TAXNODE($P(TYPE,";"))
  1.  I TYPE[";" S TYPE=$P($G(TYPE),";",2)
  1.  I TYPE="PXD(811.2," D  G ADDEX
  1.  .I $G(TAXTYPE)="R"!($G(TAXTYPE)="B") D DATA^PXRMSTA2(FILE,.DA,"RAMIS(71,","",.STATUS)
  1.  ;Handle drug finding items
  1.  I TYPE["PSDRUG("!(TYPE["PS(50.605")!(TYPE["PSNDF") D  G ADDEX
  1.  .D SRXTYL^PXRMRXTY(NODE,.RXTYPE)
  1.  .D DATA^PXRMSTA2(FILE,.DA,"DRUG",.RXTYPE,.STATUS)
  1.  ;Radiology and orderable item finding item
  1.  D DATA^PXRMSTA2(FILE,.DA,TYPE,"",.STATUS)
  1. ADDEX ;
  1.  I '$D(STATUS) S UPDATE=0 Q
  1.  S STAT="" F  S STAT=$O(STATUS(STAT)) Q:STAT=""!(WILD)=1  D
  1.  .I STAT["*" S WILD=1 Q
  1.  .S CSTATUS(STAT)=""
  1.  I WILD=1 K CSTATUS S CSTATUS("*")=""
  1.  S UPDATE=1 D DISPLAY(GBL,UPDATE,.WILD,0)
  1.  Q
  1.  ;
  1. ADDDEL(ANS,GBL,FILE,TYPE,NODE,WILD,DA,UPDATE,DELALL) ;
  1.  I $G(ANS)="" S ANS=$$PROMPT("S^A:ADD STATUS;D:DELETE A STATUS;S:SAVE AND QUIT;Q:QUIT WITHOUT SAVING CHANGES")
  1.  I "ADDASQ"'[ANS Q
  1.  I ANS="A",WILD=1 D
  1.  .W !,"Wildcard is already on the status list all possible statuses will be evaluated."
  1.  .W !,"To add a specific status please remove the wildcard first."
  1.  .S UPDATE=0 H 1
  1.  I ANS="A",WILD=0 D ADD(GBL,FILE,.CSTATUS,TYPE,.WILD,.DA,.UPDATE)
  1.  I ANS="D" D DELETE(GBL,FILE,.CSTATUS,NODE,.WILD,.DA,.UPDATE,.DELALL)
  1.  I ANS="S" S UPDATE="S"
  1.  I ANS="Q" S UPDATE="Q"
  1.  I UPDATE'="S",UPDATE'="Q" S DELALL=0 D ADDDEL("",GBL,FILE,TYPE,NODE,.WILD,.DA,.UPDATE,.DELALL)
  1.  ; only update the new record if the action is Save
  1.  I UPDATE="S" D UPDATE(FILE,.UPDATE,.CSTATUS,.DA,.DELALL)
  1.  Q
  1.  ;
  1. ASK(STR,HTEXT) ;
  1.  N DIR,HTEXT
  1.  I '$D(HTEXT) S HTEXT(1)="Enter 'Y' to continue editing the Status List or '^' to Quit"
  1.  S DIR(0)="YA0"
  1.  S DIR("A")=STR
  1.  S DIR("B")="N"
  1.  S DIR("?")="Select either 'Y' or 'N' or '^' to quit. Enter ?? for detail help."
  1.  S DIR("??")=U_"D HELP^PXRMEUT(.HTEXT)"
  1.  D ^DIR
  1.  Q Y
  1.  ;
  1. CLEAR(GBL,FILE,DA) ;
  1.  N IEN,NODE,DIK,TEMP
  1.  I FILE="D" S DIK="^PXD(811.9,"_DA(2)_",20,"_DA(1)_",5,"
  1.  I FILE="T" S DIK="^PXRMD(811.5,"_DA(2)_",20,"_DA(1)_",5,"
  1.  S DA=0 F  S DA=$O(@GBL@(DA(2),20,DA(1),5,DA)) Q:DA'>0  S TEMP(DA)=""
  1.  S DA=0 F  S DA=$O(TEMP(DA)) Q:DA'>0  D ^DIK
  1.  Q
  1.  ;
  1. DEFAULT(GBL,TYPE,NODE,RFILE,DELETE,DA) ;
  1.  N ANS,FDA,FILE,IND,MSG,STATUS,TERMIEN
  1.  S FILE=""
  1.  I TYPE["PXRMD(811.5," D
  1.  .S TERMIEN=$P($G(TYPE),";")
  1.  .S TYPE=$$TERMSTAT(TERMIEN) I TYPE=0 S STATUS="" Q
  1.  .I TYPE["PXD" S TAXTYPE=$$TAXTYPE(TERMIEN,"")
  1.  I TYPE=0 Q
  1.  I TYPE["PXD(811.2,",$G(TAXTYPE)="" S TAXTYPE=$$TAXNODE($P(TYPE,";"))
  1.  I TYPE[";" S TYPE=$P($G(TYPE),";",2)
  1.  I TYPE="PXD(811.2," D
  1.  .I $G(TAXTYPE)="R"!($G(TAXTYPE)="B") S FILE=70
  1.  I FILE="",TYPE="ORD(101.43," S FILE=100
  1.  I FILE="",TYPE="RAMIS(71," S FILE=70
  1.  I FILE="",TYPE["PSDRUG("!(TYPE["PS(50.605")!(TYPE["PSNDF") D
  1.  .N DSTATUS,NAME,STATUSI,STATUSN,STATUSO,RXTYPE
  1.  .D SRXTYL^PXRMRXTY(NODE,.RXTYPE)
  1.  .I $D(RXTYPE("O")) D DEFAULT^PXRMSTAT(52,.STATUSO) D
  1.  ..F IND=1:1:STATUSO(0) S DSTATUS(STATUSO(IND))=""
  1.  .I $D(RXTYPE("I")) D DEFAULT^PXRMSTAT(55,.STATUSI) D
  1.  ..F IND=1:1:STATUSI(0) S DSTATUS(STATUSI(IND))=""
  1.  .I $D(RXTYPE("N")) D DEFAULT^PXRMSTAT("55NVA",.STATUSN) D
  1.  ..F IND=1:1:STATUSN(0) S DSTATUS(STATUSN(IND))=""
  1.  .S NAME="",IND=0 F  S NAME=$O(DSTATUS(NAME)) Q:NAME=""  D
  1.  ..S IND=IND+1 S STATUS(IND)=NAME
  1.  .S STATUS(0)=IND
  1.  I '$D(STATUS) D DEFAULT^PXRMSTAT(FILE,.STATUS)
  1.  F IND=1:1:STATUS(0) Q:$D(MSG)>0  D
  1.  .I DELETE=1 S CSTATUS(STATUS(IND))="" Q
  1.  .I $D(@GBL@(DA(2),20,DA(1),5,"B",STATUS(IND))) Q
  1.  .I RFILE="D" S FDA(811.90221,"+3,"_DA(1)_","_DA(2)_",",.01)=STATUS(IND)
  1.  .I RFILE="T" S FDA(811.54,"+3,"_DA(1)_","_DA(2)_",",.01)=STATUS(IND)
  1.  .D UPDATE^DIE("","FDA","","MSG")
  1.  I $D(MSG)>0 D AWRITE^PXRMUTIL("MSG") H 2
  1.  Q
  1.  ;
  1. DELETE(GBL,FILE,CSTATUS,NODE,WILD,DA,UPDATE,DELALL) ;
  1.  N ANS,CNT,DIK,NUM,NAME,DIR,TMP,TMPARR,Y
  1.  S CNT=0,NAME="" F  S NAME=$O(CSTATUS(NAME)) Q:NAME=""  D
  1.  .S CNT=CNT+1 S TMPARR(CNT)=CNT_" - "_NAME,TMP(CNT)=NAME
  1.  S DIR(0)="LO^1:"_CNT_""
  1.  M DIR("A")=TMPARR
  1.  S DIR("A")="Select which status to be deleted"
  1.  ;S DIR("?")=HELP
  1.  D ^DIR
  1.  I $D(DTOUT)!($D(DUOUT))!($G(Y)="") Q
  1.  S CNT=0 F X=1:1:$L(Y(0)) D
  1.  .I $E(Y(0),X)="," S CNT=CNT+1,NUM=$P(Y(0),",",CNT) S NAME=TMP(NUM) K CSTATUS(NAME) I NAME["*" S WILD=0
  1.  S UPDATE=1
  1.  I FILE="T",$D(CSTATUS)'>0 S DELALL=1
  1.  D DISPLAY(GBL,UPDATE,.WILD,DELALL)
  1.  Q
  1.  ;
  1. DISPLAY(GBL,UPDATE,WILD,DELALL) ;
  1.  ;Display statuses defined in the 5 node or display statuses if CStatus
  1.  ;array has been loaded
  1.  N NAME
  1.  S NAME=""
  1.  I ((UPDATE=1)&(DELALL=1))!(($D(CSTATUS)'>0)&(UPDATE=0)&(GBL["811.5")&('$D(@GBL@(DA(2),20,DA(1),5)))) W !!,"No statuses defined for this finding item" W ! Q 
  1.  W !!,"Statuses already defined for this finding item:"
  1.  I $D(CSTATUS)'>0,UPDATE=0 D 
  1.  .F  S NAME=$O(@GBL@(DA(2),20,DA(1),5,"B",NAME)) Q:NAME=""  D
  1.  ..I NAME["*" S WILD=1
  1.  ..W !,NAME S CSTATUS(NAME)=$O(^PXD(811.9,DA(2),20,DA(1),5,"B","NAME",""))
  1.  I UPDATE=1 F  S NAME=$O(CSTATUS(NAME)) Q:NAME=""  W !,NAME I NAME["*" S WILD=1
  1.  W !
  1.  Q
  1.  ;
  1. PROMPT(STR) ;
  1.  N DIR,HTEXT
  1.  S HTEXT(1)="Select 'A' to add a status to the current status list.\\Select 'D' to"
  1.  S HTEXT(2)="delete a status from the list.\\Select 'S' to save your changes and quit. "
  1.  S HTEXT(3)="\\Select 'Q' to quit without saving your changes."
  1.  S DIR(0)=STR
  1.  S DIR("B")="S"
  1.  S DIR("?")="Select one of the above option or '^' to quit. Enter ?? for detail help."
  1.  S DIR("??")=U_"D HELP^PXRMEUT(.HTEXT)"
  1.  D ^DIR
  1.  I $G(Y)="" S Y=U
  1.  Q Y
  1.  ;
  1. STATUS(DA,FILE) ;
  1.  N ANS,DELSTS,DELALL,GBL,NODE,PXRMRX,STATUS,STS,TAXIEN,TERMIEN,TAXTYPE,TTYPE,TYPE
  1.  N RXTYPE,TAXNODE,TERMTYPE,Y
  1.  N CSTATUS,UPDATE,HTEXT,OSTAUS,WILD
  1.  S DA(2)=DA(1),DA(1)=DA,DA="",UPDATE=0,DELALL=0
  1.  I FILE="D" S GBL="^PXD(811.9)"
  1.  I FILE="T" S GBL="^PXRMD(811.5)"
  1.  S NODE=$G(@GBL@(DA(2),20,DA(1),0))
  1.  S TYPE=$P($G(@GBL@(DA(2),20,DA(1),0)),U)
  1.  S WILD=0
  1.  ;Check for current defined statuses if none set the default values
  1.  I FILE="D",$P($G(@GBL@(DA(2),20,DA(1),5,0)),U,4)'>0 D DEFAULT(GBL,TYPE,NODE,FILE,0,.DA)
  1.  ;Display the current status 
  1.  D DISPLAY(GBL,UPDATE,.WILD,DELALL)
  1.  ;Do inital prompt
  1.  D ADDDEL($G(ANS),GBL,FILE,TYPE,NODE,WILD,.DA,.UPDATE,.DELALL)
  1.  Q
  1.  ;
  1. TAXNODE(TAXIEN) ;Determine if the taxonomy is searching Problem List and/or
  1.  ;CPT codes which can be Radiology Procedures.
  1.  N PL,RAD,RESULT
  1.  S (PL,RAD,RESULT)=0
  1.  I (^PXD(811.2,TAXIEN,"APDS",71,"NNODES")>0),($D(^PXD(811.2,TAXIEN,20,"AE","CPT"))) S RAD=1
  1.  I ^PXD(811.2,TAXIEN,"APDS",9000011,"NNODES")>0 S PL=1
  1.  I RAD=1,PL=1 S RESULT="B"
  1.  I RAD=1,PL=0 S RESULT="R"
  1.  I RAD=0,PL=1 S RESULT="P"
  1.  Q RESULT
  1.  ;
  1. TAXTYPE(TERMIEN,HELP) ;Determine the Rx type of the term and the type of
  1.  ;taxonomy
  1.  N ARRAY,BOTH,CNT,IEN,TAXNODE,RAD,PL,RESULT,TYPE
  1.  S (BOTH,PL,RAD,RESULT)=0
  1.  S IEN=0 F  S IEN=$O(^PXRMD(811.5,TERMIEN,20,IEN)) Q:+IEN'>0  D
  1.  .S TAXNODE=$G(^PXRMD(811.5,TERMIEN,20,IEN,0))
  1.  .S ARRAY($P($P($G(TAXNODE),U),";"))=""
  1.  I $D(ARRAY)>0 S IEN=0 F  S IEN=$O(ARRAY(IEN)) Q:IEN'>0  D
  1.  .S TYPE=$$TAXNODE(IEN)
  1.  .I TYPE="R" S RAD=1
  1.  .I TYPE="P" S PL=1
  1.  .I TYPE="B" S BOTH=1
  1.  I RAD=1,PL=1 S RESULT="B" Q
  1.  I RAD=1,PL=0,BOTH=0 S RESULT="R"
  1.  I RAD=0,PL=1,BOTH=0 S RESULT="P"
  1.  Q RESULT
  1.  ;
  1. TERMSTAT(TIEN) ;
  1.  N CNT,FIEN,NODE
  1.  S (CNT,FIEN)=0
  1.  S TYPE=0 F  S FIEN=$O(^PXRMD(811.5,TIEN,20,FIEN)) Q:+FIEN=0!(CNT=1)  D
  1.  . S NODE=$G(^PXRMD(811.5,TIEN,20,FIEN,0)),TYPE=$P(NODE,U),CNT=CNT+1
  1.  Q TYPE
  1.  ;
  1. UPDATE(FILE,UPDATE,CSTATUS,DA,DELALL) ;
  1.  N FDA,MSG,NAME
  1.  I UPDATE="S" S UPDATE=1
  1.  I UPDATE=0,$D(CSTATUS) G EXIT
  1.  D CLEAR(GBL,FILE,.DA)
  1.  I $D(CSTATUS)'>0 S UPDATE=0,DELALL=0 G EXIT
  1.  I $D(CSTATUS)'>0 S UPDATE=1,DELALL=1 G EXIT
  1.  S NAME="" F  S NAME=$O(CSTATUS(NAME)) Q:NAME=""!($D(MSG)>0)  D
  1.  .I FILE="D" S FDA(811.90221,"+3,"_DA(1)_","_DA(2)_",",.01)=NAME
  1.  .I FILE="T" S FDA(811.54,"+3,"_DA(1)_","_DA(2)_",",.01)=NAME
  1.  .D UPDATE^DIE("","FDA","","MSG")
  1.  I $D(MSG)>0 D AWRITE^PXRMUTIL("MSG") H 2
  1. EXIT ;
  1.  Q
  1.  ;
  1. WARN ;
  1.  ;If the whole entry is being deleted don't give the warning.
  1.  I $G(PXRMDEFD) Q
  1.  I $G(PXRMTMD) Q
  1.  ;Do not execute as part of exchange.
  1.  I $G(PXRMEXCH) Q
  1.  N TEXT
  1.  S TEXT(1)=""
  1.  S TEXT(2)="Since you changed the value of Rx Type, you should review the status list"
  1.  S TEXT(3)="for the finding to make sure it is still appropriate."
  1.  S TEXT(4)=""
  1.  D EN^DDIOL(.TEXT)
  1.  Q
  1.  ;