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