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

DICU1.m

Go to the documentation of this file.
  1. DICU1 ;SEA/TOAD,SF/TKW-VA FileMan: Lookup Tools, Get IDs & Index ;26JUNE2011
  1. ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
  1. ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
  1. ;;Licensed under the terms of the Apache License, Version 2.0.
  1. ;
  1. IDENTS(DIFLAGS,DIFILE,DIDS,DIWRITE,DIDENT,DINDEX) ;
  1. ; get definition of fields to return with each entry
  1. ;
  1. ID1 ; prepare to build output processor:
  1. ;
  1. S DIDS=";"_DIDS_";"
  1. I DIDS[";@;" S DIDS("@")=""
  1. E S:DIDS'[";-WID;" DIDS("WID")="" S:DIDS=";;" DIDS("FID")=""
  1. N DICRSR,DICOUNT S (DICRSR,DICOUNT)=0
  1. I DIFLAGS["P" S DICRSR=1,DIDENT(-3)="IEN"
  1. N DIFORMAT,DIDEFALT S DIDEFALT=$S(DIFLAGS["I":"I",1:"E")
  1. ;
  1. ID1A ; for Lister: add indexed fields to DIDENT array (to build 1 nodes)
  1. ;
  1. I DIFLAGS[3,DIFLAGS'["S",DIDS'[";-IX",'$D(DIDS("@")) D
  1. . S DIDENT=-2,DIDENT(-2)=1
  1. . D THROW^DICU11(DIFLAGS,.DIDENT,.DIDS,.DICRSR,.DICOUNT,DIDEFALT,.DINDEX)
  1. . S DIDENT=0
  1. ;
  1. ID2 ; decide whether to auto-include the .01 in the field list
  1. ; will come out in 1 node for Lister, in "ID" nodes for Finder
  1. ;
  1. N DIUSEKEY S (DIUSEKEY,DIDENT)=0
  1. I '$D(DIDS("@")),DIDS'[";-.01;",DIFLAGS'["S" D
  1. . I DIFLAGS[4 S DIUSEKEY="1F" Q
  1. . I DIDS[";.01;"!(DIDS[";.01E") Q
  1. . S DIUSEKEY=1 N DISUB F DISUB=1:1:DINDEX("#") D Q:'DIUSEKEY
  1. . . Q:$G(DINDEX(DISUB,"FIELD"))'=.01 ;**GFT
  1. . . S DIUSEKEY=DINDEX(DISUB,"FILE")'=DIFILE
  1. . Q
  1. I DIUSEKEY S DIDENT(-2)=1,DIDENT=.01
  1. N DICODE,DIDEF,DIEFROM,DIETO,DINODE,DIPIECE,DISTORE,DITYPE,DIFRMAT2
  1. N DILENGTH,DIOUTI S DILENGTH=$L(DIDS,";"),DIOUTI=0
  1. ;
  1. ID3 ; Process auto-included .01 field (if included) on first pass,
  1. ; Start loop to process each field from DIFIELDS parameter
  1. ; and Identifiers.
  1. ;
  1. F D Q:$G(DIERR)!DIOUTI
  1. . S DIFORMAT=""
  1. . I DIUSEKEY D Q
  1. . . D BLD S DIUSEKEY=$S(DIUSEKEY="1F":"F",1:0)
  1. . . S:DIDENT=-2 DIDENT=.01 Q
  1. . D Q:'DIDENT
  1. . . S DIUSEKEY=0
  1. . . ; Find next Identifier
  1. . . I $D(DIDS("FID")) D Q
  1. . . . S DIDENT=$O(^DD(DIFILE,0,"ID",DIDENT))
  1. . . . I 'DIDENT K DIFRMAT2
  1. . . . I DIDENT="" S:DIDS=";;" DIOUTI=1 K DIDS("FID")
  1. . .
  1. ID4 . . ; Find next field in DIFIELDS input parameter.
  1. . .
  1. . . S DICOUNT=DICOUNT+1
  1. . . S DIDENT=$P(DIDS,";",DICOUNT)
  1. . . I DIDENT="",DICOUNT'<DILENGTH S DIOUTI=1
  1. ID4A . . ; process IX specifier
  1. . . I DIDENT["IX" D Q
  1. . . . I $$BADIX(DIDENT) D ERR202 Q
  1. . . . Q:DIDS[";-IX;"
  1. . . . D THROW^DICU11(DIFLAGS,.DIDENT,.DIDS,.DICRSR,.DICOUNT,DIDEFALT,.DINDEX)
  1. . .
  1. ID4B . . ; process FID, WID, and @ specifiers
  1. . .
  1. . . I DIDENT["FID" D S DIDENT="" Q
  1. . . . Q:DIDENT="-FID"!(DIDS[";-FID;")
  1. . . . D GETFORM^DICU11(.DIDENT,.DIFRMAT2,.DIDS,.DICOUNT)
  1. . . . S DIDS("FID")=1 Q
  1. . . I DIDENT["WID" D S DIDENT="" Q
  1. . . . I DIDENT'="WID",DIDENT'="-WID" D ERR202 Q
  1. . . . Q:DIDENT="-WID"!(DIDS[";-WID;")
  1. . . . D WRITEID^DICU11(DIFILE,.DIDENT,.DICRSR) K DIDS("WID") Q
  1. ID4X ..I $TR(DIDENT,"@")]"" N X,DICR S X=DIDENT I +X'=$TR(X,"IE") D Q:$D(X) ;***GFT
  1. ...N DISVFILE
  1. ...S DISVFILE=DIFILE N DIFILE S DIFILE=DISVFILE ;Q^DIC2 KILLS DIFILE
  1. ...D EXPR^DICOMP(DIFILE,"m",X) Q:'$D(X) ;Create the code to do the computation
  1. ...S DICRSR=DICRSR+1 S:$G(Y)["m" DIGFT(DICRSR,"MULTIPLE")=1 S:$G(Y)["D" DIGFT(DICRSR,"DATE")=1
  1. ...S Y="C"_(DICOUNT-1) ;COMPUTED
  1. ...S:DIFLAGS["P" $P(DIDENT(-3),U,DICRSR)=Y ;THIS WILL BECOME THE PACKED "MAP"
  1. ...S:DIFLAGS'["P" DIDENT(-3,$O(^DD(DISVFILE," "),-1)+1,Y)="" ;THIS IS THE UNPACKED MAP
  1. ...S DIDENT(DICRSR,Y,0)="D COMP^DICU1("_DICRSR_")"
  1. ...M DIGFT(DICRSR)=X S DIDENT=""
  1. . . I DIDENT["@" D:DIDENT'="@" ERR202 Q
  1. . . I 'DIDENT D:DIDENT'="" ERR202 Q
  1. . .
  1. ID4C . . ; process field # specifiers from DIFIELDS parameter
  1. . .
  1. . . D GETFORM^DICU11(.DIDENT,.DIFORMAT,.DIDS,.DICOUNT)
  1. .
  1. . ; Here we quit if field is already in the DIDENT array.
  1. . I DIDS=";;",DIFLAGS[4,DIUSEKEY'="F",DIDENT=.01 Q
  1. . I DIDS=";;",DIFLAGS[3,DINDEX("FLIST")[("^"_DIDENT_"^") Q
  1. .
  1. ID5 . ; for file IDs, we skip non-display IDs
  1. .
  1. . N DIPLUS S DIPLUS=+DIDENT
  1. . N DILAST S DILAST=$P(DIDENT,DIPLUS,2,999)
  1. . I DIDENT["-" D Q
  1. . . I DILAST'="" D ERR202 Q
  1. . . I '$D(^DD(DIFILE,-DIPLUS)) D ERR(501,DIFILE,"","",-DIPLUS) Q
  1. . E I (DILAST'?.1"E".1"I")&(DILAST'?.1"I".1"E") D ERR202 Q
  1. . Q:DIDS[(";-"_DIDENT_";")
  1. . I $D(DIDS("FID")) D I DINODE="W """"" Q
  1. . . S DINODE=$G(^DD(DIFILE,0,"ID",DIDENT))
  1. . I $G(DIFRMAT2)]"" S DIFORMAT=DIFRMAT2
  1. . D BLD Q
  1. ;
  1. ID6 ; Write Identifiers: add to output processor
  1. ; ID Parameter: add ID parameter to output processor
  1. ;
  1. Q:$G(DIERR)
  1. I $D(DIDS("WID")) D WRITEID^DICU11(DIFILE,.DIDENT,.DICRSR)
  1. I DIWRITE'="" D
  1. . S DIDENT="ZZZ ID" I DIFLAGS["P" S DICRSR=DICRSR+1
  1. . S DIDENT(DICRSR,DIDENT,0)="N DIMSG "_DIWRITE
  1. . S:DIFLAGS["P" $P(DIDENT(-3),U,DICRSR)="IDP" Q
  1. Q
  1. ;
  1. BLD ; get fetch code for value
  1. D GET^DICUIX1(DIFILE,DIFILE,DIDENT,.DIDEF,.DICODE) Q:DIDEF=""!$G(DIERR)
  1. I DIFORMAT="" S DIFORMAT=$S(DIUSEKEY="1F":"I",1:DIDEFALT)
  1. D
  1. . N DIVALUE S DIVALUE=DIDENT
  1. . I DIUSEKEY'["F",$D(DIDS("FID")),DIDENT'=.01 S DIVALUE="FID("_DIVALUE_")"
  1. . S:DIFORMAT="I" DIVALUE=DIVALUE_DIFORMAT
  1. . I DIFLAGS["P" S $P(DIDENT(-3),U,(DICRSR+1))=DIVALUE Q
  1. . Q:DIUSEKEY="1F"
  1. . S DIDENT(-3,+DIDENT,DIVALUE)="" Q
  1. BLD1 ; set up format code and load with fetch code into DIDENT
  1. N DIVALUE,DISUB S DIVALUE=DICODE,DISUB=0
  1. S DITYPE=$P(DIDEF,U,2) I DITYPE'["C" D
  1. . S DIVALUE=$$FORMAT^DICU11(DIDENT,DICODE,DIUSEKEY,DIFORMAT,DIDEFALT,DIFLAGS)
  1. I DIUSEKEY="1F",DIDENT=.01 S DIDENT=-2,DISUB=.01
  1. I DIFLAGS["P" S DICRSR=DICRSR+1
  1. I DITYPE'["C" S DIDENT(DICRSR,DIDENT,DISUB,DIFORMAT)=DIVALUE Q
  1. S DIDENT(DICRSR,DIDENT,0)=DIVALUE
  1. S DIDENT(DICRSR,DIDENT,0,"TYPE")="C"
  1. Q
  1. ;
  1. ;
  1. COMP(DIGFTI) ;EXECUTE A COMPUTED FIELD! COME HERE FROM DICU2
  1. N X,Y,J,I
  1. S J=0 F Y=$L(DIEN,","):-1:1 S X=$P(DIEN,",",Y) I X]"" N @("D"_J) S @("D"_J)=X,J=J+1 ;Temporarily set D0,D1,etc
  1. M X=DIGFT(DIGFTI)
  1. I '$D(DIGFT(DIGFTI,"MULTIPLE")) X X D:$D(DIGFT(DIGFTI,"DATE")) S ^TMP("DIMSG",$J,1)=X Q ;SINGLE-VALUED COMPUTED EXPRESSION
  1. .N Y S Y=X X:Y ^DD("DD") S X=Y
  1. N DICMX S DICMX="S ^($O(^TMP(""DIMSG"",$J,999),-1)+1)=X" X X ;MULTIPLE-VALUED COMPUTED EXPRESSION
  1. Q
  1. ;
  1. ;
  1. ERR(DIERN,DIFILE,DIENS,DIFIELD,DI1) ;
  1. ;
  1. ; add an error to the message array
  1. ; GET
  1. ;
  1. N DIPE
  1. S DIPE("FILE")=$G(DIFILE)
  1. S DIPE("IEN")=$G(DIENS)
  1. S DIPE("FIELD")=$G(DIFIELD)
  1. S DIPE(1)=$G(DI1)
  1. D BLD^DIALOG(DIERN,.DIPE,.DIPE)
  1. Q
  1. ;
  1. ERR202 D ERR(202,"","","","FIELDS") Q
  1. ;
  1. BADIX(DIDENT) ;
  1. ;
  1. N DIBAD S DIBAD=DIDENT'="IX"&(DIDENT'="-IX")&(DIDENT'?1"IX"1"E".1"I")
  1. S DIBAD=DIDENT'?1"IX"1"I".1"E"&DIBAD
  1. Q DIBAD
  1. ;
  1. ; 202 The input parameter that identifies the |1
  1. ;