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

XBDIQ1.m

Go to the documentation of this file. 
  1. XBDIQ1 ; IHS/ADC/GTH - SPECIAL EN^DIQ1 DATA PULLER ; [ 02/07/97   3:02 PM ]
  1.  ;;3.0;IHS/VA UTILITIES;;FEB 07, 1997
  1.  ;
  1.  ; Thanks to Paul Wesley, DSD/OIRM, for the original routine.
  1.  ;
  1.  ; Documentation for the APIs in this routine can be found
  1.  ; in routine XBDIQ0.
  1.  ;
  1. DOC ;
  1.  Q
  1.  ;
  1. EN ;PEP - Returns single entries
  1.  NEW XB0,XBDIC,XBFN,XBGBL,XBNEWPAR,XBGL
  1.  S XBDIC=DIC
  1.  I DA'=+DA D PARSE(DA)
  1.  D DICFNGL(DIC),^XBSFGBL(XBFN,.XBGBL)
  1.  S XBDIC=$P(XBGBL,"DA,"),DIC=XBDIC
  1.  D ENDIQ1,EXIT
  1.  Q
  1.  ;
  1. ENP(DIC,DA,DR,DIQ,XBFMT) ;PEP - param pass into EN
  1.  S:'$D(DIQ(0)) DIQ(0)=$G(XBFMT)
  1.  D EN
  1.  Q
  1.  ;
  1. ENPM(DIC,DA,DR,DIQ,XBFMT) ;PEP - param pass into EN
  1.  S:'$D(DIQ(0)) DIQ(0)=$G(XBFMT)
  1.  D ENM
  1.  Q
  1.  ;
  1. ENM ;PEP - get multiple entries
  1.  NEW XB0,XBDIC,XBFN,XBGBL,XBNEWPAR,XBGL
  1.  S XBDIC=DIC
  1.  S:$G(DA)="" DA=0
  1.  I DA'=+DA D PARSE(DA)
  1.  S:(+$G(DIQ(0))'>0) DIQ(0)=1_$G(DIQ(0))
  1.  D DICFNGL(DIC)
  1.  S XBDIC=$P(XBGL,"DA,"),DIC=XBDIC,DA=0,DIC(0)=""
  1.  I $D(DIC("S")) S XBDICS=DIC("S")
  1.  F  S DA=$O(@(XBDIC_"DA)")) Q:DA'>0  D
  1.  . S XB0=@(XBDIC_"DA,0)")
  1.  . I $L($G(XBDICS)) S DIC("S")=XBDICS
  1.  . I $D(DIC("S")) S X="`"_DA,DIC(0)="N" D ^DIC Q:Y'>0
  1.  . S DIC=XBDIC
  1.  . D ENDIQ1
  1.  .Q
  1.  KILL XBDICS
  1.  S DA=""
  1.  D EXIT
  1.  Q
  1.  ;
  1. ENDIQ1 ;EP - call EN^DIQ1
  1.  NEW XBDIQ,XBGBL0,XBGLS,XBLVL,XBUDA,XB,XB0
  1.  S XBDIQ=DIQ,XBDIQ(0)=$G(DIQ(0))
  1.  NEW DIQ,XBDTMP
  1.  D LEVELS
  1.  D
  1.  . NEW DIC,DR,DA
  1.  . D SETDIQ1
  1.  . D ENDIQ1X
  1.  .Q
  1.  D PULLDIQ1
  1.  Q:XBDIQ(0)'["I"  ;  Internal if XB["I"
  1.  KILL DIC
  1.  S DIC=XBDIC ;reset dic
  1.  S DIQ(0)="I"
  1.  D ENDIQ1X,PULLDIQ1
  1.  KILL ^UTILITY("DIQ1",$J)
  1.  Q
  1.  ;
  1. ENDIQ1X ;EP - to call DIQ1 with new  
  1.  I $G(XBDIQ1(0))["N" S DIQ(0)=$G(DIQ(0))_"N"
  1.  I $G(XBFMT)["N",$G(DIQ(0))'["N" S DIQ(0)=$G(DIQ(0))_"N"
  1.  D EN^XBNEW("ENDIQ1XN^XBDIQ1","DR;DA;DIC;DIQ;XBDTMP;XBSRCFL")
  1.  Q
  1.  ;
  1. ENDIQ1XN ;EP  
  1.  S DIQ="XBDTMP("
  1.  D EN^DIQ1
  1.  Q
  1.  ;
  1. EXIT ;EP
  1.  KILL XBI,XBDEST,XBNEWPAR
  1.  Q
  1.  ;
  1. PULLDIQ1 ;EP - PULL FROM ^UTILITY("DIQ1",$J)
  1.  D %XY
  1.  S XBGLS=XBDIQ_"""ID"")" S @XBGLS=DA_":"_DIC_":"_XBUDA_":"_+XBDIQ(0)
  1.  D %XY^%RCR
  1.  Q
  1.  ;
  1. %XY ;EP - set %X & %Y to format
  1.  KILL %X,%Y
  1.  S XBUDA=""
  1. 0 I +XBDIQ(0)=0 D  Q
  1.  . S %X="XBDTMP("_XBFN_","_DA_",",%Y=XBDIQ
  1.  .Q
  1. 1 I +XBDIQ(0)=1 D  Q
  1.  . S %X="XBDTMP("_XBFN_",",%Y=XBDIQ,XBUDA=DA_","
  1.  .Q
  1. 2 I +XBDIQ(0)=2 D  Q
  1.  . S %X="XBDTMP("_XBFN_","
  1.  . D  ;build da(x),..,da subscripts
  1.  .. S %Y=""
  1.  .. F %=1:1 Q:'$G(DA(%))  S %Y=DA(%)_","_%Y
  1.  ..Q
  1.  . S XBUDA=%Y_DA_","
  1.  . S %Y=XBDIQ_%Y
  1.  .Q
  1. %XYE Q 
  1.  ;--
  1. DICFNGL(X) ;EP - set XBFN & XBGL0 return 1 error
  1.  NEW Y
  1.  KILL XBGL,XBFN
  1.  I X S XBFN=X D ^XBSFGBL(XBFN,.XBGL) Q
  1.  I 'X S Y=X_"0)" S XBFN=+$P(@Y,U,2),Y=0 D ^XBSFGBL(XBFN,.XBGL)
  1.  Q
  1.  ;
  1. DICFNGLX ;
  1.  Q
  1.  ;
  1. VAL(DIC,DA,DR) ;PEP - extrinsic pull a value for a field
  1.  NEW DIQ,XBT
  1.  S DIQ="XBT("
  1.  D EN
  1.  Q $G(XBT(+DR))
  1.  ;
  1. VALI(DIC,DA,DR) ;PEP - extrinsic pull a value for a field
  1.  NEW DIQ,XBT
  1.  S DIQ="XBT(",DIQ(0)="I"
  1.  D EN
  1.  Q $G(XBT(+DR,"I"))
  1.  ;
  1. PARSE(XBDA) ;PEP - parse DA literal into da array
  1.  NEW D,I,J
  1.  F I=1:1 S D(I)=$P(XBDA,",",I) Q:D(I)=""
  1.  S I=I-1
  1.  F J=0:1:I-1 S DA(J)=D(I-J)
  1.  F J=0:1:I-1 F  Q:(DA(J)=+DA(J))  S DA(J)=@(DA(J))
  1.  S DA=DA(0)
  1.  KILL DA(0)
  1.  Q
  1.  ;
  1. DIC(XBFN) ;PEP -  Extrensic entry to return DIC from global
  1.  NEW XBDIC
  1.  D EN^XBSFGBL(XBFN,.XBDIC)
  1.  S XBDIC=$P(XBDIC,"DA,")
  1.  Q XBDIC
  1.  ;
  1. LEVELS ;EP - setup XB_FN_DA_DR_FLD arrays for upper levels it they exist
  1.  ;set bottom level
  1.  KILL XB
  1.  S XBLVL=0
  1.  S XB(0,"DR")=DR,XB(0,"DA")=DA,XB(0,"FN")=XBFN
  1.  S XB(0,"FLD")=""
  1.  S XB(0,"PAR")=$G(^DD(XB(0,"FN"),0,"UP"))
  1.  S:XB(0,"PAR")]"" XB(XBLVL,"FLD")=$O(^DD(XB(0,"PAR"),"SB",XB(0,"FN"),""))
  1.  D ^XBSFGBL(XB(0,"FN"),.XBGBL0)
  1.  S XB(0,"GBL")=$P(XBGBL0,"DA,")
  1.  I XB(0,"PAR")]"" S XB(0+1,"FN")=XB(0,"PAR"),XBLVL=XBLVL+1 D PARENT
  1.  Q
  1.  ;
  1. PARENT ; gather parent information
  1.  ; build elements from XBFN(XBLVL)
  1.  S XB(XBLVL,"DA")=DA(XBLVL)
  1.  S XB(XBLVL,"DR")=XB(XBLVL-1,"FLD")
  1.  S XB(XBLVL,"FLD")=""
  1.  S XB(XBLVL,"PAR")=$G(^DD(XB(XBLVL,"FN"),0,"UP"))
  1.  S:XB(XBLVL,"PAR")]"" XB(XBLVL,"FLD")=$O(^DD(XB(XBLVL,"PAR"),"SB",XB(XBLVL,"FN"),""))
  1.  D ^XBSFGBL(XB(XBLVL,"FN"),.XBGBL0)
  1.  S XB(XBLVL,"GBL")=$P(XBGBL0,"DA,")
  1.  I XB(XBLVL,"PAR")]"" S XB(XBLVL+1,"FN")=XB(XBLVL,"PAR"),XBLVL=XBLVL+1 D PARENT
  1. EPAR ;
  1.  Q
  1.  ;
  1. SETDIQ1 ;EP - set DR(fn and DA(fn arrays for DIQ1
  1.  F XBLVL=0:1 Q:'$D(XB(XBLVL))  D
  1.  . S DR(XB(XBLVL,"FN"))=XB(XBLVL,"DR")
  1.  . S DA(XB(XBLVL,"FN"))=XB(XBLVL,"DA")
  1.  . S DIC=XB(XBLVL,"GBL")
  1.  . S DR=XB(XBLVL,"DR")
  1.  . S DA=XB(XBLVL,"DA")
  1.  .Q
  1.  ;   kill off redundant DR( and DA(
  1.  S XBLVL=XBLVL-1
  1.  KILL DR(XB(XBLVL,"FN")),DA(XB(XBLVL,"FN"))
  1.  Q
  1.  ;