PXRMV1ID ; SLC/PJH - Build selectable code lists ;10/25/1999
;;1.5;CLINICAL REMINDERS;;Jun 19, 2000
;
;Implementation utility
;----------------------
START ;Lock entire taxonomy file
I $$LOCK D
.D BMES^XPDUTL("Generating selectable codes from taxonomy file")
.K ^TMP("PXRM",$J)
.N TAXIND
.S TAXIND=0
.F S TAXIND=$O(^PXD(811.2,TAXIND)) Q:'TAXIND D
..;Remove any existing entries
..D DEL(TAXIND)
..;Build new list of selectable codes
..D BCL(TAXIND)
.D BMES^XPDUTL("Generation completed")
D UNLOCK
Q
;
;Build the list of codes for one taxonomy
;----------------------------------------
BCL(TAXIND) ;
N CODELIST,IC,FINDING,FILE,HIGH,LOW,NCE,TEMP
;
;Setup file names for indirection, these will hold the taxonomy lists.
N ICD9IEN,ICPTIEN
S ICD9IEN="^TMP(""PXRM"",$J,""ICD9IEN"")"
S ICPTIEN="^TMP(""PXRM"",$J,""ICPTIEN"")"
;
S NCE=0
F FILE=80,81 D
.S IC=0
.F S IC=$O(^PXD(811.2,TAXIND,FILE,IC)) Q:+IC=0 D
..S TEMP=$G(^PXD(811.2,TAXIND,FILE,IC,0))
..;Append the taxonomy and finding information to CODELIST.
..S NCE=NCE+1
..S CODELIST(NCE)=TEMP_U_FILE
;CODELIST is LOW_U_HIGH_U_FILE
;Go through the standard coded list and get the file IEN for each entry.
F IC=1:1:NCE D
.S LOW=$P(CODELIST(IC),U,1)
.S HIGH=$P(CODELIST(IC),U,2)
.S FILE=$P(CODELIST(IC),U,3)
.I FILE=80 D ICD9(LOW,HIGH) Q
.I FILE=81 D ICPT(LOW,HIGH) Q
;
;Store the results.
D STORE(TAXIND)
K ^TMP("PXRM",$J,"ICD9IEN")
K ^TMP("PXRM",$J,"ICPTIEN")
Q
;
;=======================================================================
DEL(TAXIND) ;Delete existing entry
K ^PXD(811.2,TAXIND,"SDX")
K ^PXD(811.2,TAXIND,"SPR")
Q
;
;Build the list of internal entries for ICD9 (File 80)
;-----------------------------------------------------
ICD9(LOW,HIGH) ;
N END,IEN,IND
S IND=LOW_" "
S END=HIGH_" "
F Q:(IND]END)!(+IND>+END)!(IND="") D
.S IEN=$O(^ICD9("BA",IND,""))
.I (+IEN>0),$$CODE^PXRMVAL($TR(IND," "),80) D
..S ^TMP("PXRM",$J,"ICD9IEN",IND)=IEN
.S IND=$O(^ICD9("BA",IND))
Q
;
;Build the list of internal entries for ICPT (File 81)
;-----------------------------------------------------
ICPT(LOW,HIGH) ;
N IEN,IND
S IND=LOW
F Q:(IND]HIGH)!(+IND>+HIGH)!(IND="") D
.S IEN=$O(^ICPT("B",IND,""))
.I (+IEN>0),$$CODE^PXRMVAL($TR(IND," "),81) D
..S ^TMP("PXRM",$J,"ICPTIEN",IND)=IEN
.S IND=$O(^ICPT("B",IND))
Q
;
;Lock the taxonomy file
LOCK() N IND,LOCK
S LOCK=0
F IND=1:1:30 Q:LOCK D
.L +^PXD(811.2):1
.S LOCK=$T
;If we can't get lock generate an error and quit.
I 'LOCK D Q 0
.D BMES^XPDUTL("Could not get lock for taxonomy file ")
Q 1
;
;Store selectable codes in taxonomy
;----------------------------------
STORE(TAXIND) ;
K ^TMP("PXRMV1ID",$J)
N FDA,FDAIEN,FITEM,I2N,IEN,IND,MSG,NAME,SEQ,SUB,TEMP
;
S NAME=$P(^PXD(811.2,TAXIND,0),U)
;
S FDAIEN(1)=TAXIND
;
S SUB="",IND=1,SEQ=0
F S SUB=$O(^TMP("PXRM",$J,"ICD9IEN",SUB)) Q:SUB="" D
.S IEN=^TMP("PXRM",$J,"ICD9IEN",SUB)
.S IND=IND+1,SEQ=SEQ+1
.S I2N="+"_IND_","_FDAIEN(1)_","
.S ^TMP("PXRMV1ID",$J,811.23102,I2N,.01)=IEN
.;S ^TMP("PXRMV1ID",$J,811.23102,I2N,.01)=SEQ
.;S ^TMP("PXRMV1ID",$J,811.23102,I2N,1)=IEN
.;S ^TMP("PXRMV1ID",$J,811.23102,I2N,3)=1
;
S SEQ=0
F S SUB=$O(^TMP("PXRM",$J,"ICPTIEN",SUB)) Q:SUB="" D
.S IEN=^TMP("PXRM",$J,"ICPTIEN",SUB)
.S IND=IND+1,SEQ=SEQ+1
.S I2N="+"_IND_","_FDAIEN(1)_","
.S ^TMP("PXRMV1ID",$J,811.23104,I2N,.01)=IEN
.;S ^TMP("PXRMV1ID",$J,811.23104,I2N,.01)=SEQ
.;S ^TMP("PXRMV1ID",$J,811.23104,I2N,1)=IEN
.;S ^TMP("PXRMV1ID",$J,811.23104,I2N,3)=1
;
;None found
I IND=1 Q
;
S TEMP="^TMP(""PXRMV1ID"","_$J_")"
D UPDATE^DIE("",TEMP,"FDAIEN","MSG")
I $D(MSG) D ERR
K ^TMP("PXRMV1ID",$J)
Q
;
;Unlock the taxonomy
;-------------------
UNLOCK L -^PXD(811.2)
Q
;
;Error Handler
;-------------
ERR N ERROR,IC,REF
S ERROR(1)="Unable to build selectable codes for taxonomy : "
S ERROR(2)=NAME
S ERROR(3)="Error in UPDATE^DIE, needs further investigation"
;Move MSG into ERROR
S REF="MSG"
F IC=4:1 S REF=$Q(@REF) Q:REF="" S ERROR(IC)=REF_"="_@REF
;Screen message
D BMES^XPDUTL(.ERROR)
;Mail Message
D ERR^PXRMV1IE(.ERROR)
Q
PXRMV1ID ; SLC/PJH - Build selectable code lists ;10/25/1999
+1 ;;1.5;CLINICAL REMINDERS;;Jun 19, 2000
+2 ;
+3 ;Implementation utility
+4 ;----------------------
START ;Lock entire taxonomy file
+1 IF $$LOCK
Begin DoDot:1
+2 DO BMES^XPDUTL("Generating selectable codes from taxonomy file")
+3 KILL ^TMP("PXRM",$JOB)
+4 NEW TAXIND
+5 SET TAXIND=0
+6 FOR
SET TAXIND=$ORDER(^PXD(811.2,TAXIND))
IF 'TAXIND
QUIT
Begin DoDot:2
+7 ;Remove any existing entries
+8 DO DEL(TAXIND)
+9 ;Build new list of selectable codes
+10 DO BCL(TAXIND)
End DoDot:2
+11 DO BMES^XPDUTL("Generation completed")
End DoDot:1
+12 DO UNLOCK
+13 QUIT
+14 ;
+15 ;Build the list of codes for one taxonomy
+16 ;----------------------------------------
BCL(TAXIND) ;
+1 NEW CODELIST,IC,FINDING,FILE,HIGH,LOW,NCE,TEMP
+2 ;
+3 ;Setup file names for indirection, these will hold the taxonomy lists.
+4 NEW ICD9IEN,ICPTIEN
+5 SET ICD9IEN="^TMP(""PXRM"",$J,""ICD9IEN"")"
+6 SET ICPTIEN="^TMP(""PXRM"",$J,""ICPTIEN"")"
+7 ;
+8 SET NCE=0
+9 FOR FILE=80,81
Begin DoDot:1
+10 SET IC=0
+11 FOR
SET IC=$ORDER(^PXD(811.2,TAXIND,FILE,IC))
IF +IC=0
QUIT
Begin DoDot:2
+12 SET TEMP=$GET(^PXD(811.2,TAXIND,FILE,IC,0))
+13 ;Append the taxonomy and finding information to CODELIST.
+14 SET NCE=NCE+1
+15 SET CODELIST(NCE)=TEMP_U_FILE
End DoDot:2
End DoDot:1
+16 ;CODELIST is LOW_U_HIGH_U_FILE
+17 ;Go through the standard coded list and get the file IEN for each entry.
+18 FOR IC=1:1:NCE
Begin DoDot:1
+19 SET LOW=$PIECE(CODELIST(IC),U,1)
+20 SET HIGH=$PIECE(CODELIST(IC),U,2)
+21 SET FILE=$PIECE(CODELIST(IC),U,3)
+22 IF FILE=80
DO ICD9(LOW,HIGH)
QUIT
+23 IF FILE=81
DO ICPT(LOW,HIGH)
QUIT
End DoDot:1
+24 ;
+25 ;Store the results.
+26 DO STORE(TAXIND)
+27 KILL ^TMP("PXRM",$JOB,"ICD9IEN")
+28 KILL ^TMP("PXRM",$JOB,"ICPTIEN")
+29 QUIT
+30 ;
+31 ;=======================================================================
DEL(TAXIND) ;Delete existing entry
+1 KILL ^PXD(811.2,TAXIND,"SDX")
+2 KILL ^PXD(811.2,TAXIND,"SPR")
+3 QUIT
+4 ;
+5 ;Build the list of internal entries for ICD9 (File 80)
+6 ;-----------------------------------------------------
ICD9(LOW,HIGH) ;
+1 NEW END,IEN,IND
+2 SET IND=LOW_" "
+3 SET END=HIGH_" "
+4 FOR
IF (IND]END)!(+IND>+END)!(IND="")
QUIT
Begin DoDot:1
+5 SET IEN=$ORDER(^ICD9("BA",IND,""))
+6 IF (+IEN>0)
IF $$CODE^PXRMVAL($TRANSLATE(IND," "),80)
Begin DoDot:2
+7 SET ^TMP("PXRM",$JOB,"ICD9IEN",IND)=IEN
End DoDot:2
+8 SET IND=$ORDER(^ICD9("BA",IND))
End DoDot:1
+9 QUIT
+10 ;
+11 ;Build the list of internal entries for ICPT (File 81)
+12 ;-----------------------------------------------------
ICPT(LOW,HIGH) ;
+1 NEW IEN,IND
+2 SET IND=LOW
+3 FOR
IF (IND]HIGH)!(+IND>+HIGH)!(IND="")
QUIT
Begin DoDot:1
+4 SET IEN=$ORDER(^ICPT("B",IND,""))
+5 IF (+IEN>0)
IF $$CODE^PXRMVAL($TRANSLATE(IND," "),81)
Begin DoDot:2
+6 SET ^TMP("PXRM",$JOB,"ICPTIEN",IND)=IEN
End DoDot:2
+7 SET IND=$ORDER(^ICPT("B",IND))
End DoDot:1
+8 QUIT
+9 ;
+10 ;Lock the taxonomy file
LOCK() NEW IND,LOCK
+1 SET LOCK=0
+2 FOR IND=1:1:30
IF LOCK
QUIT
Begin DoDot:1
+3 LOCK +^PXD(811.2):1
+4 SET LOCK=$TEST
End DoDot:1
+5 ;If we can't get lock generate an error and quit.
+6 IF 'LOCK
Begin DoDot:1
+7 DO BMES^XPDUTL("Could not get lock for taxonomy file ")
End DoDot:1
QUIT 0
+8 QUIT 1
+9 ;
+10 ;Store selectable codes in taxonomy
+11 ;----------------------------------
STORE(TAXIND) ;
+1 KILL ^TMP("PXRMV1ID",$JOB)
+2 NEW FDA,FDAIEN,FITEM,I2N,IEN,IND,MSG,NAME,SEQ,SUB,TEMP
+3 ;
+4 SET NAME=$PIECE(^PXD(811.2,TAXIND,0),U)
+5 ;
+6 SET FDAIEN(1)=TAXIND
+7 ;
+8 SET SUB=""
SET IND=1
SET SEQ=0
+9 FOR
SET SUB=$ORDER(^TMP("PXRM",$JOB,"ICD9IEN",SUB))
IF SUB=""
QUIT
Begin DoDot:1
+10 SET IEN=^TMP("PXRM",$JOB,"ICD9IEN",SUB)
+11 SET IND=IND+1
SET SEQ=SEQ+1
+12 SET I2N="+"_IND_","_FDAIEN(1)_","
+13 SET ^TMP("PXRMV1ID",$JOB,811.23102,I2N,.01)=IEN
+14 ;S ^TMP("PXRMV1ID",$J,811.23102,I2N,.01)=SEQ
+15 ;S ^TMP("PXRMV1ID",$J,811.23102,I2N,1)=IEN
+16 ;S ^TMP("PXRMV1ID",$J,811.23102,I2N,3)=1
End DoDot:1
+17 ;
+18 SET SEQ=0
+19 FOR
SET SUB=$ORDER(^TMP("PXRM",$JOB,"ICPTIEN",SUB))
IF SUB=""
QUIT
Begin DoDot:1
+20 SET IEN=^TMP("PXRM",$JOB,"ICPTIEN",SUB)
+21 SET IND=IND+1
SET SEQ=SEQ+1
+22 SET I2N="+"_IND_","_FDAIEN(1)_","
+23 SET ^TMP("PXRMV1ID",$JOB,811.23104,I2N,.01)=IEN
+24 ;S ^TMP("PXRMV1ID",$J,811.23104,I2N,.01)=SEQ
+25 ;S ^TMP("PXRMV1ID",$J,811.23104,I2N,1)=IEN
+26 ;S ^TMP("PXRMV1ID",$J,811.23104,I2N,3)=1
End DoDot:1
+27 ;
+28 ;None found
+29 IF IND=1
QUIT
+30 ;
+31 SET TEMP="^TMP(""PXRMV1ID"","_$JOB_")"
+32 DO UPDATE^DIE("",TEMP,"FDAIEN","MSG")
+33 IF $DATA(MSG)
DO ERR
+34 KILL ^TMP("PXRMV1ID",$JOB)
+35 QUIT
+36 ;
+37 ;Unlock the taxonomy
+38 ;-------------------
UNLOCK LOCK -^PXD(811.2)
+1 QUIT
+2 ;
+3 ;Error Handler
+4 ;-------------
ERR NEW ERROR,IC,REF
+1 SET ERROR(1)="Unable to build selectable codes for taxonomy : "
+2 SET ERROR(2)=NAME
+3 SET ERROR(3)="Error in UPDATE^DIE, needs further investigation"
+4 ;Move MSG into ERROR
+5 SET REF="MSG"
+6 FOR IC=4:1
SET REF=$QUERY(@REF)
IF REF=""
QUIT
SET ERROR(IC)=REF_"="_@REF
+7 ;Screen message
+8 DO BMES^XPDUTL(.ERROR)
+9 ;Mail Message
+10 DO ERR^PXRMV1IE(.ERROR)
+11 QUIT
