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

PXRMGEDT.m

Go to the documentation of this file. 
  1. PXRMGEDT ; SLC/PJH - PXRM General Edit/Add. ;01/28/2013
  1.  ;;2.0;CLINICAL REMINDERS;**26**;Feb 04, 2005;Build 404
  1.  ;
  1.  ;
  1.  ;Called from protocol PXRM SELECTION ADD
  1.  ;
  1. ADD(TYP) ;
  1.  N DIC,DIDEL,DLAYGO,DTOUT,DUOUT,FILE,HED,PXRMHD,X,Y
  1.  W IORESET
  1.  ;
  1.  ;Ignore finding type parameters
  1.  I "FPAR"=TYP D DUMMY^PXRMRUTL H 1 Q
  1.  ;
  1.  ;Edit dialog
  1.  I "DLGE"=TYP D ADD^PXRMDEDT Q
  1.  ;
  1.  ;Allow auto generate of reminder dialogs
  1.  I TYP["DLG" D ^PXRMDBLD Q
  1.  ;
  1.  ;Finding Item Parameter
  1.  I TYP="FIP" S FILE="801.43",HED="FINDING ITEM PARAMETER"
  1.  ;
  1.  ;Reminder Category
  1.  I TYP="RCAT" S FILE="811.7",HED="REMINDER CATEGORY"
  1.  ;
  1.  ;Resolution Status
  1.  I TYP="RESN" S FILE="801.9",HED="RESOLUTION STATUS"
  1.  ;
  1.  ;Health Factor Resolution
  1.  I TYP="SHFR" S FILE="801.95",HED="HEALTH FACTOR"
  1.  ;
  1.  F  D  Q:(X="")!$D(DUOUT)!$D(DTOUT)
  1.  .S DIC=FILE,DLAYGO=DIC,DIDEL=DIC,DIC(0)="QAELX"
  1.  .S DIC("A")="Select new "_HED_" name: "
  1.  .I TYP="SHFR" S DIC(0)="QAEL"
  1.  .D ^DIC Q:X=""
  1.  .I X=(U_U) S DTOUT=1
  1.  .I Y=-1 S DUOUT=1 W !,"Details not saved",! Q
  1.  .Q:$D(DTOUT)!$D(DUOUT)
  1.  .;Check if exists
  1.  .I ($P(Y,U,3)'=1) W !,"already exists" Q
  1.  .S DA=$P(Y,U)
  1.  .;Edit resolution status
  1.  .I TYP="RESN" D EDIT^PXRMSEDT("^PXRMD(801.9,",DA)
  1.  .;Edit others
  1.  .I TYP'="RESN" D EDIT(TYP,DA,1)
  1.  .S DUOUT=1
  1.  Q
  1.  ;
  1. DIE(HDR,FILE) ;Lock and edit
  1.  I FILE=801.45 W "ED - EDIT "_HDR,!!,PXRMHD,!
  1.  ;Display resolution details if finding type parameter edit
  1.  I FILE=801.45,$G(PXRMINST)'=1 D
  1.  .N RSUB,RNAM
  1.  .S RSUB=$P($G(^PXRMD(801.45,PXRMFIEN,1,PXRMFSUB,0)),U) Q:'RSUB
  1.  .S RNAM=$P($G(^PXRMD(801.9,RSUB,0)),U)
  1.  .S:RNAM="" RNAM=RSUB W "RESOLUTION STATUS : ",RNAM
  1.  D:$$LOCK(FILE) ^DIE,UNLOCK(FILE)
  1.  Q
  1.  ;
  1.  ;Called by protocol PXRM GENERAL EDIT
  1.  ;------------------------------------
  1. EDIT(TYP,DA,ADD) ;
  1.  N DIC,DIDEL,DIE,DR,DTOUT,DUOUT,Y
  1.  W IORESET
  1.  S VALMBCK="R"
  1.  ;
  1.  ;Taxonomy Dialog
  1.  I TYP="DTAX" D
  1.  .I $$TLOCK(811.2,DA) D  D TUNLOCK(811.2,DA)
  1.  ..;Initialize the selectable codes if none exist
  1.  ..I ('$D(^PXD(811.2,DA,"SDX")))&('$D(^PXD(811.2,DA,"SPR"))) D
  1.  ...D BUILD^PXRMTDUP(DA)
  1.  ..;
  1.  ..N DIE,DR
  1.  ..S DIE="^PXD(811.2,"
  1.  ..;
  1.  ..W !,"Dialog Text Fields"
  1.  ..S DR=".03;3107;3108;3111;3112"
  1.  ..D ^DIE
  1.  ..I $D(Y) Q
  1.  ..;
  1.  ..W !!,"Dialog Selectable codes"
  1.  ..S DR="3102;3104"
  1.  ..D ^DIE
  1.  ..I $D(Y) Q
  1.  ..;
  1.  ..W !!,"Dialog Generation Parameters"
  1.  ..S DR="3106;3110"
  1.  ..D ^DIE
  1.  ;
  1.  ;Finding Item Parameter
  1.  I TYP="FIP" D
  1.  .S DIE="^PXRMD(801.43,",DR=".01;.02;.03;.04",DIDEL=801.43
  1.  .D DIE("FINDING ITEM PARAMETER",801.43)
  1.  ;
  1.  ;Finding Type Parameter
  1.  I TYP="FPAR" D
  1.  .;Programmer mode
  1.  .S:$G(PXRMINST)=1 DR=1,DR(2,801.451)="1;3;4;5",DIE="^PXRMD(801.45,"
  1.  .;Site mode
  1.  .I $G(PXRMINST)'=1 D
  1.  ..S DR="1;3;4;5",DIE="^PXRMD(801.45,PXRMFIEN,1,",DA(1)=PXRMFIEN
  1.  ..S DR(2,801.4515)="2;4;5;6;1"
  1.  .D DIE("FINDING TYPE PARAMETER",801.45)
  1.  ;
  1.  ;Reminder Category
  1.  I TYP="RCAT" D
  1.  .S DIE="^PXRMD(811.7,",DR=".01;1;2;10",DIDEL=811.7
  1.  .D DIE("CATEGORY",811.7)
  1.  ;
  1.  ;Resolution Status
  1.  I TYP="RESN" D
  1.  .I $$LOCK(801.9) D EDIT^PXRMSEDT("^PXRMD(801.9,",.DA),UNLOCK(811.9)
  1.  ;
  1.  ;Health Factor Resolution
  1.  I TYP="SHFR" D
  1.  .S DIE="^PXRMD(801.95,",DR=".01;.02",DIDEL=801.95
  1.  .D DIE("HEALTH FACTOR RESOLUTIONS",811.7)
  1.  ;
  1.  ;Skip rebuild if editting taxonomy called from dialog edit
  1.  I PXRMGTYP["DLG" Q
  1.  ;
  1.  ;Deleted ???
  1.  I '$D(DA) S VALMBCK="Q" Q
  1.  ;Redisplay changes
  1.  I 'ADD D BUILD^PXRMGEN
  1.  Q
  1.  ;
  1.  ;
  1. LOCK(FILE) ;Lock the entire file
  1.  L +^PXRMD(FILE):DILOCKTM I  Q 1
  1.  E  W !!,?5,"Another user is editing this file, try later" H 2
  1.  Q 0
  1.  ;
  1.  ;
  1. UNLOCK(FILE) ;Unlock the file
  1.  L -^PXRMD(FILE)
  1.  Q
  1.  ;Build the list of codes for one taxonomy
  1.  ;----------------------------------------
  1. SEL(TAXIND) ;
  1.  N CODELIST,IC,FINDING,FILE,HIGH,LOW,NCE,TEMP
  1.  ;
  1.  ;Setup file names for indirection, these will hold the taxonomy lists.
  1.  N ICD9IEN,ICPTIEN
  1.  S ICD9IEN="^TMP(""PXRM"",$J,""ICD9IEN"")"
  1.  S ICPTIEN="^TMP(""PXRM"",$J,""ICPTIEN"")"
  1.  ;
  1.  S NCE=0
  1.  F FILE=80,81 D
  1.  .S IC=0
  1.  .F  S IC=$O(^PXD(811.2,TAXIND,FILE,IC)) Q:+IC=0  D
  1.  ..S TEMP=$G(^PXD(811.2,TAXIND,FILE,IC,0))
  1.  ..;Append the taxonomy and finding information to CODELIST.
  1.  ..S NCE=NCE+1
  1.  ..S CODELIST(NCE)=TEMP_U_FILE
  1.  ;CODELIST is LOW_U_HIGH_U_FILE
  1.  ;Go through the standard coded list and get the file IEN for each entry.
  1.  F IC=1:1:NCE D
  1.  .S LOW=$P(CODELIST(IC),U,1)
  1.  .S HIGH=$P(CODELIST(IC),U,2)
  1.  .S FILE=$P(CODELIST(IC),U,3)
  1.  .I FILE=80 D ICD9(LOW,HIGH) Q
  1.  .I FILE=81 D ICPT(LOW,HIGH) Q
  1.  ;
  1.  ;Store the results.
  1.  D STORE(TAXIND)
  1.  K ^TMP("PXRM",$J,"ICD9IEN")
  1.  K ^TMP("PXRM",$J,"ICPTIEN")
  1.  Q
  1.  ;
  1.  ;=======================================================================
  1. DEL(TAXIND) ;Delete existing entry
  1.  K ^PXD(811.2,TAXIND,"SDX")
  1.  K ^PXD(811.2,TAXIND,"SPR")
  1.  Q
  1.  ;
  1.  ;Build the list of internal entries for ICD9 (File 80)
  1.  ;-----------------------------------------------------
  1. ICD9(LOW,HIGH) ;
  1.  N END,IEN,IND
  1.  S IND=LOW_" "
  1.  S END=HIGH_" "
  1.  F  Q:(IND]END)!(+IND>+END)!(IND="")  D
  1.  .S IEN=$O(^ICD9("BA",IND,""))
  1.  .I (+IEN>0),$$CODE^PXRMVAL($TR(IND," "),80) D
  1.  ..S ^TMP("PXRM",$J,"ICD9IEN",IND)=IEN
  1.  .S IND=$O(^ICD9("BA",IND))
  1.  Q
  1.  ;
  1.  ;Build the list of internal entries for ICPT (File 81)
  1.  ;-----------------------------------------------------
  1. ICPT(LOW,HIGH) ;
  1.  N IEN,IND
  1.  S IND=LOW
  1.  F  Q:(IND]HIGH)!(+IND>+HIGH)!(IND="")  D
  1.  .S IEN=$O(^ICPT("B",IND,""))
  1.  .I (+IEN>0),$$CODE^PXRMVAL($TR(IND," "),81) D
  1.  ..S ^TMP("PXRM",$J,"ICPTIEN",IND)=IEN
  1.  .S IND=$O(^ICPT("B",IND))
  1.  Q
  1.  ;
  1.  ;Store selectable codes in taxonomy
  1.  ;----------------------------------
  1. STORE(TAXIND) ;
  1.  K ^TMP("PXRMGEDT",$J)
  1.  N FDA,FDAIEN,FITEM,I2N,IEN,IND,MSG,NAME,SEQ,SUB,TEMP
  1.  ;
  1.  S NAME=$P(^PXD(811.2,TAXIND,0),U)
  1.  ;
  1.  S FDAIEN(1)=TAXIND
  1.  ;
  1.  S SUB="",IND=1,SEQ=0
  1.  F  S SUB=$O(^TMP("PXRM",$J,"ICD9IEN",SUB)) Q:SUB=""  D
  1.  .S IEN=^TMP("PXRM",$J,"ICD9IEN",SUB)
  1.  .S IND=IND+1,SEQ=SEQ+1
  1.  .S I2N="+"_IND_","_FDAIEN(1)_","
  1.  .S ^TMP("PXRMGEDT",$J,811.23102,I2N,.01)=IEN
  1.  ;
  1.  S SEQ=0
  1.  F  S SUB=$O(^TMP("PXRM",$J,"ICPTIEN",SUB)) Q:SUB=""  D
  1.  .S IEN=^TMP("PXRM",$J,"ICPTIEN",SUB)
  1.  .S IND=IND+1,SEQ=SEQ+1
  1.  .S I2N="+"_IND_","_FDAIEN(1)_","
  1.  .S ^TMP("PXRMGEDT",$J,811.23104,I2N,.01)=IEN
  1.  ;
  1.  ;None found
  1.  I IND=1 Q
  1.  ;
  1.  S TEMP="^TMP(""PXRMGEDT"","_$J_")"
  1.  D UPDATE^DIE("",TEMP,"FDAIEN","MSG")
  1.  I $D(MSG) D ERR
  1.  K ^TMP("PXRMGEDT",$J)
  1.  Q
  1.  ;
  1.  ;Error Handler
  1.  ;-------------
  1. ERR N ERROR,IC,REF
  1.  S ERROR(1)="Unable to build selectable codes for taxonomy : "
  1.  S ERROR(2)=NAME
  1.  S ERROR(3)="Error in UPDATE^DIE, needs further investigation"
  1.  ;Move MSG into ERROR
  1.  S REF="MSG"
  1.  F IC=4:1 S REF=$Q(@REF) Q:REF=""  S ERROR(IC)=REF_"="_@REF
  1.  ;Screen message
  1.  D BMES^XPDUTL(.ERROR)
  1.  Q
  1.  ;
  1. TLOCK(FILE,DA) ;Lock the record
  1.  L +^PXD(FILE,DA):DILOCKTM I  Q 1
  1.  E  W !!,?5,"Another user is editing this file, try later" H 2 Q 0
  1.  ;
  1.  ;
  1. TUNLOCK(FILE,DA) ;Unlock the record
  1.  L -^PXD(FILE,DA)
  1.  Q