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