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

XUMFQR.m

Go to the documentation of this file. 
  1. XUMFQR ;ISS/RAM - Master File Query Response ;06/28/00
  1.  ;;8.0;KERNEL;**407,502**;Jul 10, 1995;Build 18
  1.  ;
  1.  Q
  1.  ;
  1. MAIN ; -- main
  1.  ;
  1.  N FIELD1,IDX,IDX1,NAME1,SUBFILE1,DATA1,IEN1,TYP1,MKEY,MKEY1,TYP,VUID,VUID1
  1.  N MFI,SEQ,NAME,QRD,SEQ,SUBFILE,IEN,CNT,DATA,ERROR,SORTBY,FILTERBY,FILTER,ERRCNT
  1.  ;
  1.  D INIT,PROCESS,MFR,SEND,EXIT
  1.  ;
  1.  Q
  1.  ;
  1. INIT ; -- initialize
  1.  ;
  1.  K ^TMP("HLA",$J)
  1.  ;
  1.  S ERROR=0,CNT=1,ERRCNT=0
  1.  ;
  1.  S HLFS=HL("FS"),HLCS=$E(HL("ECH")),HLSCS=$E(HL("ECH"),4)
  1.  ;
  1.  Q
  1.  ;
  1. PROCESS ; -- pull message text
  1.  ;
  1.  F  X HLNEXT Q:HLQUIT'>0  D
  1.  .Q:$P(HLNODE,HLFS)=""
  1.  .Q:"^MSH^MSA^QRD^"'[(U_$P(HLNODE,HLFS)_U)
  1.  .D @($P(HLNODE,HLFS))
  1.  ;
  1.  Q
  1.  ;
  1. MSH ; -- MSH segment
  1.  ;
  1.  Q
  1.  ;
  1. QRD ; -- QRD segment
  1.  ;
  1.  Q:ERROR
  1.  ;
  1.  S MFI=$P(HLNODE,HLFS,10),FILTER=$P(MFI,HLCS,2),MFI=$P(MFI,HLCS)
  1.  I MFI="" S ERROR="1^MFI not resolved HLNODE: "_$TR(HLNODE,HLFS,"#") Q
  1.  S IFN=$O(^DIC(4.001,"MFID",MFI,0))
  1.  I 'IFN S ERROR="1^IFN not resolved HLNODE: "_$TR(HLNODE,HLFS,"#") Q
  1.  I '$$VFILE^DILFD(IFN) S ERROR="1^invalid file number" Q
  1.  S DATA=$G(^DIC(4.001,+IFN,0)),SORTBY=$P(DATA,U,8),FILTERBY=$P(DATA,U,9)
  1.  ;
  1.  ; -- get root of file
  1.  S ROOT=$$ROOT^DILFD(IFN,,1)
  1.  ;
  1.  S QRD=HLNODE
  1.  ;
  1.  Q
  1.  ;
  1. MFR ; -- response
  1.  ;
  1.  D MSA,QRD1,MFI,MFE
  1.  ;
  1.  Q
  1.  ;
  1. MSA ; -- Acknowledgement
  1.  ;
  1.  N X
  1.  S X="MSA"_HLFS_$S(ERROR:"AE",1:"AA")_HLFS_HL("MID")_HLFS_$P(ERROR,U,2)
  1.  S ^TMP("HLA",$J,CNT)=X
  1.  S CNT=CNT+1
  1.  ;
  1.  Q
  1.  ;
  1. QRD1 ; -- query definition segment
  1.  ;
  1.  Q:ERROR
  1.  ;
  1.  S ^TMP("HLA",$J,CNT)=$G(QRD)
  1.  S CNT=CNT+1
  1.  ;
  1.  Q
  1.  ;
  1. MFI ; master file identifier segment
  1.  ;
  1.  Q:ERROR
  1.  ;
  1.  S ^TMP("HLA",$J,CNT)=$$MFI^XUMFMFI(MFI,"Standard Terminology","MUP",$$NOW^XLFDT,$$NOW^XLFDT,"NE")
  1.  S CNT=CNT+1
  1.  ;
  1.  Q
  1.  ;
  1. MFE ; master file entry segment
  1.  ;
  1.  Q:ERROR
  1.  ;
  1.  S VUID=0 F  S VUID=$O(@ROOT@($S(SORTBY'="":SORTBY,1:"AMASTERVUID"),VUID)) Q:'VUID  D  Q:ERROR
  1.  .I SORTBY="" S IEN=$O(@ROOT@("AMASTERVUID",VUID,1,0)) Q:'IEN
  1.  .I SORTBY'="" S IEN=$O(@ROOT@(SORTBY,VUID,0)) Q:'IEN
  1.  .;
  1.  .I FILTER'="" D  Q:VALUE'=FILTER
  1.  ..S DATA=$G(^DIC(4.001,+IFN,0)),FILTERBY=$P(DATA,U,9)
  1.  ..I FILTERBY="" S VALUE="ERROR" Q  ;add error processing
  1.  ..S IDX=$O(^DIC(4.001,+IFN,1,"B",FILTERBY,0))
  1.  ..S DATA=$G(^DIC(4.001,+IFN,1,+IDX,0)),FIELD=$P(DATA,U,2)
  1.  ..S TYP=$P(DATA,U,3),TYP=$$GET1^DIQ(771.4,(+TYP_","),.01)
  1.  ..S VUID1=$P(DATA,U,13)
  1.  ..S VALUE=$$VVAL(IFN,IEN_",",FIELD,$G(VUID1),TYP)
  1.  .;
  1.  .S ^TMP("HLA",$J,CNT)=$$MFE^XUMFMFE("MUP","",$$NOW^XLFDT,MFI_"@"_VUID)
  1.  .S CNT=CNT+1
  1.  .D ZRT
  1.  ;
  1.  Q
  1.  ;
  1. ZRT ; data segments
  1.  ;
  1.  Q:ERROR
  1.  ;
  1.  S SEQ=0
  1.  F  S SEQ=$O(^DIC(4.001,IFN,1,"ASEQ",SEQ)) Q:'SEQ  D
  1.  .S IDX=$O(^DIC(4.001,IFN,1,"ASEQ",SEQ,0)) Q:'IDX
  1.  .S DATA=$G(^DIC(4.001,+IFN,1,+IDX,0)),NAME=$P(DATA,U)
  1.  .S TYP=$P(DATA,U,3),TYP=$$GET1^DIQ(771.4,(+TYP_","),.01)
  1.  .S FIELD=$P(DATA,U,2),SUBFILE=$P(DATA,U,4),MKEY=$P(DATA,U,6)
  1.  .S VUID1=$P(DATA,U,13),WP=$P(DATA,U,16)
  1.  .;
  1.  .I NAME="Status" D  Q
  1.  ..S:IFN'=757.33 ^TMP("HLA",$J,CNT)="ZRT"_HLFS_NAME_HLFS_(+$P($$GETSTAT^XTID(IFN,,IEN_","),U))
  1.  ..S:IFN=757.33 ^TMP("HLA",$J,CNT)="ZRT"_HLFS_NAME_HLFS_$$STAT^XUMF502
  1.  ..S CNT=CNT+1
  1.  .;
  1.  .I WP D WP Q
  1.  .;
  1.  .I SUBFILE D SUBFILE Q
  1.  .;
  1.  .S VALUE=$$VALUE(IFN,IEN_",",FIELD,VUID1,TYP) ;Q:VALUE=""
  1.  .;
  1.  .S ^TMP("HLA",$J,CNT)="ZRT"_HLFS_NAME_HLFS_VALUE
  1.  .S CNT=CNT+1
  1.  ;
  1.  Q
  1.  ;
  1. SUBFILE ;
  1.  ;
  1.  Q:ERROR
  1.  ;
  1.  I NAME="Status" D  Q
  1.  .S:IFN'=757.33 ^TMP("HLA",$J,CNT)="ZRT"_HLFS_NAME_HLFS_+$$GETSTAT^XTID(IFN,,IEN_",")
  1.  .S:IFN=757.33 ^TMP("HLA",$J,CNT)="ZRT"_HLFS_NAME_HLFS_$$STAT^XUMF502
  1.  .S CNT=CNT+1
  1.  ;
  1.  N ROOT
  1.  ;
  1.  S ROOT=$$ROOT^DILFD(SUBFILE,(","_IEN_","),1)
  1.  ;
  1.  I MKEY="" S ERROR="1^null lookup column parameter for subfile: "_SUBFILE Q
  1.  ;
  1.  S IEN1=0
  1.  F  S IEN1=$O(@ROOT@(IEN1)) Q:'IEN1  D  Q:ERROR
  1.  .;
  1.  .I $D(^DIC(4.001,IFN,1,IDX,1,"ASEQ1")) D SUBREC Q
  1.  .;
  1.  .S VALUE=$$VALUE(SUBFILE,IEN1_","_IEN_",",FIELD,VUID1,TYP) ;Q:VALUE=""
  1.  .;
  1.  .S ^TMP("HLA",$J,CNT)="ZRT"_HLFS_NAME_HLFS_VALUE
  1.  .S CNT=CNT+1
  1.  ;
  1.  Q
  1.  ;
  1. SUBREC ; -- sub-records
  1.  ;
  1.  Q:ERROR
  1.  ;
  1.  N SEQ1,FIELD1,NAME1,VUID2,TYP2
  1.  ;
  1.  S SEQ1=0
  1.  F  S SEQ1=$O(^DIC(4.001,IFN,1,IDX,1,"ASEQ1",SEQ1)) Q:'SEQ1  D  Q:ERROR
  1.  .S IDX1=$O(^DIC(4.001,IFN,1,IDX,1,"ASEQ1",SEQ1,0))
  1.  .;
  1.  .S NAME1=$P(^DIC(4.001,IFN,1,IDX,1,IDX1,0),U,2)
  1.  .I NAME1="" S ERROR="1^subrecord sequence name missing SUBFILE : "_SUBFILE Q
  1.  .S FIELD1=$P(^DIC(4.001,IFN,1,IDX,1,IDX1,0),U,3)
  1.  .I FIELD1="" S ERROR="1^subrecord sequence number missing SUBFILE : "_SUBFILE Q
  1.  .S VUID2=$P(^DIC(4.001,IFN,1,IDX,1,IDX1,0),U,4)
  1.  .S TYP2=$P(^DIC(4.001,IFN,1,IDX,1,IDX1,0),U,5)
  1.  .;
  1.  .S VALUE=$$VALUE(SUBFILE,IEN1_","_IEN_",",FIELD1,VUID2,TYP2) ;Q:VALUE=""
  1.  .;
  1.  .S ^TMP("HLA",$J,CNT)="ZRT"_HLFS_NAME1_HLFS_VALUE
  1.  .S CNT=CNT+1
  1.  ;
  1.  Q
  1.  ;
  1. SEND ; -- send HL7 message
  1.  ;
  1.  S HLP("PRIORITY")="I"
  1.  D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"GM",1,.HLRESLT)
  1.  ;
  1.  ; check for error
  1.  I ($P($G(HLRESLT),U,3)'="") D  Q
  1.  .S ERROR=1_U_$P(HLRESLT,HLFS,3)_U_$P(HLRESLT,HLFS,2)_U_$P(HLRESLT,U)
  1.  ;
  1.  ; successful call, message ID returned
  1.  S ERROR="0^"_$P($G(HLRESLT),U,1)
  1.  ;
  1.  Q
  1.  ;
  1. EXIT ; -- exit
  1.  ;
  1.  D CLEAN^DILF
  1.  ;
  1.  K ^TMP("HLA",$J)
  1.  ;
  1.  Q
  1.  ;
  1. WP ;
  1.  ;
  1.  N WP,I,J
  1.  ;
  1.  S I=$$GET1^DIQ(IFN,IEN_",",FIELD,,"WP")
  1.  ;
  1.  Q:'$D(WP)
  1.  ;
  1.  S ^TMP("HLA",$J,CNT)="ZRT"_HLFS_NAME_HLFS_$G(WP(1))
  1.  ;
  1.  S I=1,J=1
  1.  F  S I=$O(WP(I)) Q:'I  D
  1.  .S ^TMP("HLA",$J,CNT,J)=WP(I)
  1.  .S J=J+1
  1.  ;
  1.  S CNT=CNT+1
  1.  ;
  1.  Q
  1.  ;
  1. ESC(VALUE) ;
  1.  ;
  1.  I VALUE["^" F  Q:VALUE'["^"  D
  1.  .S VALUE=$P(VALUE,"^")_"\F\"_$P(VALUE,"^",2,9999)
  1.  I VALUE["&" F  Q:VALUE'["&"  D
  1.  .S VALUE=$P(VALUE,"&")_"\T\"_$P(VALUE,"&",2,9999)
  1.  ;
  1.  Q VALUE
  1.  ;
  1. VVAL(IFN,IENS,FIELD,VUID,TYP) ;
  1.  ;
  1.  Q:IFN="" "" Q:FIELD="" "" Q:IENS="" ""
  1.  ;
  1.  S:$G(TYP)="" TYP="ST"
  1.  S VUID=$S($G(VUID)'="":":99.99",1:"")
  1.  I IFN=757.33,$G(VUID)'="" S VUID=":5"
  1.  ;
  1.  S VALUE=$$GET1^DIQ(IFN,IENS,FIELD_VUID) Q:VALUE="" ""
  1.  ;S VALUE=$$GET1^DIQ(IFN,IENS,FIELD) Q:VALUE="" ""
  1.  S VALUE=$$DTYP^XUMFP(VALUE,TYP,HLCS,1)
  1.  S VALUE=$$ESC(VALUE)
  1.  ;
  1.  ;I IFN=757.32,FIELD=.02 Q $$MAPDEF
  1.  ;
  1.  ;Q $$VAL^XUMF0(IFN,FIELD,VUID,VALUE,IENS)
  1.  ;
  1.  Q VALUE
  1.  ;
  1. VALUE(IFN,IENS,FIELD,VUID,TYP) ;
  1.  ;
  1.  Q:IFN="" "" Q:FIELD="" "" Q:IENS="" ""
  1.  ;
  1.  S:$G(TYP)="" TYP="ST"
  1.  ;
  1.  S VALUE=$$GET1^DIQ(IFN,IENS,FIELD) Q:VALUE="" ""
  1.  S VALUE=$$DTYP^XUMFP(VALUE,TYP,HLCS,1)
  1.  S VALUE=$$ESC(VALUE)
  1.  ;
  1.  I IFN=757.33,FIELD=.02 Q $$MAPDEF
  1.  ;
  1.  Q VALUE
  1.  ;
  1. MAPDEF() ;
  1.  ;
  1.  N X,Y
  1.  S X=$O(^LEX(757.32,"B",VALUE,0)) Q:'X 0
  1.  S Y=$G(^LEX(757.32,X,2))
  1.  Q $P(Y,U,3)
  1.  ;