CIAZGRU ;MSC/IND/DKM - Generic Retrieval Utility ;29-Aug-2011 13:52;PLS
;;1.4;GENERIC RETRIEVAL UTILITY;;Feb 14, 2008
;;Copyright 2000-2008, Medsphere Systems Corporation
;=================================================================
;Modification 09/03/2010;MSC/MMT;Implement specific code to handle the AUDIT file
; EP: Main entry point for user interaction
ENTRY N GRU,CRT,ABORT,WHEN
S GRU=$$GETIEN^CIAZGUTP(19950.41,"Select Retrieval: ","N X S X=^(0) I $P(X,U,3)=DUZ!$P(X,U,4)",.ABORT)
Q:$G(ABORT)
D GETCRT(GRU,.CRT,,.ABORT)
Q:$G(ABORT)
S WHEN=$$DIR^CIAZGUTP("DO^::FR","Run at what time","NOW",,.ABORT)
D:'$G(ABORT) SUBMIT(GRU,WHEN,.CRT)
Q
; EP: Submit a query
SUBMIT(GRU,WHEN,CRT,GBL) ;
N SRT,PRT,RSLT
D GETITEMS(GRU,30,.SRT),GETITEMS(GRU,40,.PRT)
S RSLT=$$SUBMIT2(GRU,.WHEN,.CRT,.SRT,.PRT,.GBL)
Q:$Q RSLT
Q
; EP: Submit a query (alternate entry)
SUBMIT2(GRU,WHEN,CRT,SRT,PRT,GBL) ;
N FDA,RSLT,IEN
S RSLT=$$RSLTID^CIAZGUTL,IEN(1)=RSLT
S FDA=$NA(FDA(19950.49,"+1,"))
S @FDA@(.01)=$$NOW^XLFDT
S @FDA@(1)=DUZ
S @FDA@(2)=$P(^CIAZG(19950.41,GRU,0),U)
S @FDA@(5)=0
S @FDA@(7)=0
S @FDA@(8)=0
S @FDA@(9)=GRU
D UPDATE^DIE(,"FDA","IEN")
I '$G(WHEN) D
.D TASK
E D RSLTUPD^CIAZGUTL(RSLT,6,$$QUEUE^CIAUTSK("TASK^CIAZGRU","Generic Retrieval Query",.WHEN,"CRT(^SRT(^PRT(^RSLT^GRU^GBL"))
Q:$Q RSLT
Q
; EP: Taskman entry point
TASK N GBLRT,GBLS,ABORT,INTRV,X,$ET,$ES
S $ET="D TASKERR^CIAZGRU",ZTREQ="@"
D RSLTUPD^CIAZGUTL(RSLT,5,1,1)
D RSLTUPD^CIAZGUTL(RSLT,3,$$NOW^XLFDT)
S GBLRT=$NA(^XTMP("CIAZGRU",RSLT)),(GBLS,PRT,ABORT)=0,INTRV=$$GET^XPAR("ALL","CIAZG UPDATE INTERVAL")
S:INTRV<100 INTRV=100
K @GBLRT
S @GBLRT@(0)=DT+10000_U_DT_U_GRU
F X="CRT","SRT","PRT" M @GBLRT@(X)=@X
D OUTPRT($NA(@GBLRT@("FLD")),GRU)
D RETRIEVE(GRU,.GBL,1)
D RSLTUPD^CIAZGUTL(RSLT,5,$S(ABORT:3,1:2),1)
D RSLTUPD^CIAZGUTL(RSLT,4,$$NOW^XLFDT)
Q
; Error handler for task
TASKERR D ^%ZTER,RSLTUPD^CIAZGUTL(RSLT,5,5),UNWIND^%ZTER
Q
; Output field list to result global
; Format in output global is:
; Item Name^Width^Format^Datatype^Item IEN^Definition IEN^Multiple IEN
OUTPRT(GBL,GRU) ;
N PRTX,LNK,ITM,FMT,TYP,WID,DTP,X
S PRTX=0
F S PRTX=$O(PRT("C",GRU,PRTX)) Q:'PRTX D
.S X=PRT(PRTX,0),LNK=$P(X,U,3),FMT=$P(X,U,4),WID=$P(X,U,5)
.S X=PRT(PRTX,-1),ITM=$P(X,U),TYP=$P(X,U,4),DTP=$P(X,U,7),LNK=$S(LNK:$P(X,U,6),1:0)
.I $L(FMT),FMT'=2,TYP<2 S @GBL@(PRTX)=ITM_U_WID_U_FMT_U_DTP_U_PRT(PRTX)
.Q:'LNK
.I TYP>1 D
..S @GBL@(PRTX)=ITM
..D OUTPRT($NA(@GBL@(PRTX)),LNK)
.E D OUTPRT(GBL,LNK)
Q
; Collect criteria for query
; GRU = GR Definition IEN
; .ARY = Array to receive data
; .VALS = Supplied values (optional)
; .ABORT= Abort flag (returned)
GETCRT(GRU,ARY,VALS,ABORT) ;
N ARYX
D GETITEMS(GRU,20,.ARY)
S ARYX=0
F S ARYX=$O(ARY(ARYX)) Q:'ARYX D Q:$G(ABORT)
.N GRU,VAL,LP,LPX,MLT,IENS
.S GRU=+$P(ARY(ARYX),U,2),MLT=+$P(ARY(ARYX),U,3),IENS=MLT_","_GRU_","
.I $D(VALS(IENS)) M VAL=VALS(IENS)
.E D
..S (LP,LPX)=0
..F S LP=$O(ARY(ARYX,10,LP)) Q:'LP S LPX=LPX+1,VAL(LPX)=ARY(ARYX,10,LP,0)
..I $P(ARY(ARYX,0),U,6) D
...N DTP,OPR,VTP,PROMPT
...M PROMPT=ARY(ARYX,20)
...K PROMPT(0)
...S DTP=+$P(ARY(ARYX,-1),U,7),OPR=+$P(ARY(ARYX,0),U,5),VTP=+$P(ARY(ARYX,0),U,6)
...S:VTP VTP=+$P($G(^CIAZG(19950.44,OPR,0)),U,2)
...X:VTP $G(^CIAZG(19950.43,DTP,10,VTP,1))
.K ARY(ARYX,10),ARY(ARYX,20)
.Q:'$D(VAL)!$G(ABORT)
.S LP=0
.F S LP=$O(VAL(LP)) Q:'LP S:$D(VAL(LP))#2 VAL("B",$S($L(VAL(LP)):VAL(LP),1:$C(1)))=""
.M ARY(ARYX,"V")=VAL
K:$G(ABORT) ARY
Q
; Perform the retrieval
; GRU = GR Definition IEN
; IENS = IENS of subfile
; or global root for a join
; TOP = Flag indicating top level file
;
RETRIEVE(GRU,IENS,TOP) ;
N IEN,FILE,ROOT,TMP,GBL,RTN,SRTL,CNT,TOT,FILEIEN,AUDIEN
S (RTN,GBLS)=GBLS+1,GBL=$NA(@GBLRT@(GBLS)),TMP=$$TMPGBL^CIAZGUTL(GBLS),TOP=+$G(TOP),IENS=$G(IENS)
S FILE=$P(^CIAZG(19950.41,GRU,0),U,2)
I $E(IENS)=U S ROOT=IENS,IENS=""
E S ROOT=$$ROOT^DILFD(FILE,","_IENS,1)
S (CNT,TOT,IEN,CNT(0))=0,TOT(0)=INTRV
;If processing the AUDIT file, branch to separate logic
G:FILE="1.1" RETAUDIT
F Q:$$ABORT S IEN=$O(@ROOT@(IEN)) Q:'IEN D
.N CRTV,PRTV,SRTV,IENX
.I TOP,TOT'<TOT(0) D UPDCNT
.S IENX=IEN_","_IENS,TOT=TOT+1
.D FETCH(GRU,IENX,.CRT,.CRTV)
.Q:'$$SCREEN(.CRT,.CRTV)
.S:TOP @GBLRT@("IEN",IEN)=""
.S CNT=CNT+1
.D FETCH(GRU,IENX,.PRT,.PRTV,.CRTV)
.D FETCH(GRU,IENX,.SRT,.SRTV,.PRTV)
.D:'$D(SRTL) BLDSRT
.D SUBFIL(GRU,IENX)
.D SORT
D MOVE
D:TOP UPDCNT
Q:$Q RTN
Q
;Handle AUDIT file differently due to different IEN structure (^DIA(File#,IEN,...))
RETAUDIT ;
S (FILEIEN,AUDIEN)=0
F Q:$$ABORT S FILEIEN=$O(@ROOT@(FILEIEN)) Q:'FILEIEN S AUDIEN=0 D
.I '$D(CRT(2)),$D(CRT(1,"V",1)),$D(CRT(1,"V",2)),$G(CRT(1,-1))["DATE/TIME RECOR" D Q
..N MSCI,MSCEND S MSCI=CRT(1,"V",1)-.01,MSCEND=$S(CRT(1,"V",2)[".":CRT(1,"V",2),1:CRT(1,"V",2)+.9) F S MSCI=$O(@ROOT@(FILEIEN,"C",MSCI)) Q:('MSCI)!(MSCI>MSCEND) D
...S AUDIEN=0 F Q:$$ABORT S AUDIEN=$O(@ROOT@(FILEIEN,"C",MSCI,AUDIEN)) Q:'AUDIEN D MSC
.F Q:$$ABORT S AUDIEN=$O(@ROOT@(FILEIEN,AUDIEN)) Q:'AUDIEN D MSC
D MOVE
D:TOP UPDCNT
Q:$Q RTN
Q
MSC S IEN=FILEIEN_","_AUDIEN
N CRTV,PRTV,SRTV,IENX
I TOP,TOT'<TOT(0) D UPDCNT
S IENX=IEN_","_IENS,TOT=TOT+1
D FETCHAUD(GRU,IENX,.CRT,.CRTV)
Q:'$$SCREEN(.CRT,.CRTV)
S:TOP @GBLRT@("IEN",IEN)=""
S CNT=CNT+1
D FETCHAUD(GRU,IENX,.PRT,.PRTV,.CRTV)
D FETCHAUD(GRU,IENX,.SRT,.SRTV,.PRTV)
D:'$D(SRTL) BLDSRT
D SUBFIL(GRU,IENX)
D SORT
Q
; Update counts in result file
UPDCNT D RSLTUPD^CIAZGUTL(RSLT,7,CNT,1):CNT'=CNT(0)
D RSLTUPD^CIAZGUTL(RSLT,8,TOT)
S TOT(0)=TOT\INTRV*INTRV+INTRV,CNT(0)=CNT
Q
; Returns true if task should abort
ABORT() Q:ABORT 1
S:$$S^%ZTLOAD ABORT=1
S:$$RSLTSTA^CIAZGUTL(RSLT)>2 ABORT=1
Q ABORT
; Iterate over subfiles
SUBFIL(GRU,IENS) ;
N PRTX,LINK,TYPE,X
S PRTX=0
F S PRTX=$O(PRT("C",GRU,PRTX)) Q:'PRTX D
.S LINK=$P(PRT(PRTX,0),U,3),TYPE=$P(PRT(PRTX,-1),U,4)
.S:LINK LINK=$P(PRT(PRTX,-1),U,6)
.Q:'LINK
.I TYPE=2 D
..S X=$$RETRIEVE(LINK,IENS),PRTV(PRTX,"I")=X,PRTV(PRTX,"E")=X
.E I TYPE=3 D
..X ^CIAZG(19950.42,+PRT(PRTX),20)
..S X=$$RETRIEVE(LINK,X),PRTV(PRTX,"I")=X,PRTV(PRTX,"E")=X
.E D:$G(PRTV(PRTX,"I")) SUBFIL(LINK,PRTV(PRTX,"I")_",")
Q
; Apply screening criteria. Returns true if all criteria met.
SCREEN(CRT,CRTV) ;EP-
N CRTX,OK,FLG,NEG
S CRTX=0,(FLG,OK)=1
F S CRTX=$O(CRTV(CRTX)) Q:'CRTX D
.N VAL,OPR,EXE,DTP,OR,X,Y
.S Y=CRT(CRTX,0),ITM=+CRT(CRTX),OPR=$P(Y,U,5),OR=$P(Y,U,4),NEG=$P(Y,U,7),DTP=$P(CRT(CRTX,-1),U,7)
.Q:'OPR
.I 'FLG,OK=OR Q
.S X=CRTV(CRTX,"I"),X("I")=X,X("E")=CRTV(CRTX,"E")
.M VAL=CRT(CRTX,"V")
.S VAL(1)=$G(VAL(1)),VAL(2)=$G(VAL(2))
.I 1
.X $G(^CIAZG(19950.43,DTP,20,OPR,1))
.S Y=$S(NEG:'$T,1:$T)
.I FLG S OK=Y,FLG=0
.E I OR S OK=OK!Y
.E S OK=OK&Y
Q OK
; Build list of sort items
BLDSRT S SRTL=0
F S SRTL=$O(SRTV(SRTL)) Q:'SRTL S SRTL(SRTL)=$S($P($G(SRT(SRTL,0)),U,5):-1,1:1)
S SRTL(999999999999)=1
Q
; Save the result of a single record retrieval in sort order
; Result saved as
; @TMP@(S1,S2...,Sn,N,S)
; where Sn = sort field values
; N = sequence # within identical sort values
; S = sequence # in PRT control array
SORT N KEY,VAL,FMT,SRTX,KEYX,PRTX
S SRTX=0,KEY=TMP
F S SRTX=$O(SRTV(SRTX)) Q:'SRTX D
.S FMT=$P(SRT(SRTX,0),U,4)
.S VAL=$G(SRTV(SRTX,$S(FMT:"E",1:"I")))
.S:VAL="" VAL=$C(0)
.S KEY=$NA(@KEY@(VAL))
S KEYX=$O(@KEY@(""),-1)+1,PRTX=0
F S PRTX=$O(PRTV(PRTX)) Q:'PRTX D
.S FMT=$P(PRT(PRTX,0),U,4)
.S:$P(PRT(PRTX,-1),U,4)>1 FMT=0
.M:$L(FMT)&(FMT'=2) @KEY@(KEYX,PRTX)=PRTV(PRTX,$S(FMT:"E",1:"I"))
Q
; Move sorted results into target global
; Iterates over each sort value in ascending or descending order
MOVE N GBLX
S GBLX=0
D MOVEX(TMP,0)
K @TMP
Q
; Recurse over each sort subscript.
MOVEX(TMP,SRTX) ;
N ORD,NXT
S SRTX=$O(SRTL(SRTX))
I 'SRTX D:$D(@TMP) Q
.S GBLX=GBLX+1
.M @GBL@(GBLX)=@TMP
S ORD=SRTL(SRTX),NXT=""
F S NXT=$O(@TMP@(NXT),ORD) Q:'$L(NXT) D
.D MOVEX($NA(@TMP@(NXT)),SRTX)
Q
; Build item array from multiple
; GRU = IEN of GR Definition
; NODE = Multiple root node
; ARY = Local array to receive data
; where N = sequence #
; I = IEN of GR Item
; D = IEN of GR Definiton
; M = IEN in multiple
; ARY(N) = I^D^M
; ARY(N,-1) = 0 node of GR Item entry
; ARY(N,x) = x node of multiple
; ARY("B",I,N) = xref
; ARY("C",D,N) = xref
GETITEMS(GRU,NODE,ARY,ARYX) ;
N SEQ,MLT,ITM,LNK
S SEQ="",ARYX=+$G(ARYX)
F S SEQ=$O(^CIAZG(19950.41,GRU,NODE,"B",SEQ)),MLT=0 Q:'$L(SEQ) D
.F S MLT=$O(^CIAZG(19950.41,GRU,NODE,"B",SEQ,MLT)) Q:'MLT D
..S ARYX=ARYX+1
..M ARY(ARYX)=^CIAZG(19950.41,GRU,NODE,MLT)
..S ITM=$P(ARY(ARYX,0),U,2),ARY("B",ITM,ARYX)="",ARY("C",GRU,ARYX)=""
..S ARY(ARYX)=ITM_U_GRU_U_MLT,ARY(ARYX,-1)=^CIAZG(19950.42,ITM,0)
..S LNK=$P(ARY(ARYX,0),U,3)
..S:LNK LNK=$P(ARY(ARYX,-1),U,6)
..D:LNK GETITEMS(LNK,NODE,.ARY,.ARYX)
Q
; Fetch specified items
; GRU = GR Definition IEN
; IENS = IENS of entry to fetch
; .ITEMS= Items control array
; .VALS = Array to receive values
; .CACHE= Array of cached values (optional)
FETCH(GRU,IENS,ITEMS,VALS,CACHE) ;
N FILE,FLDS,TYPE,DATA,LINK,ITMX,ITM,IEN,X,Y
; Build list of fields, computed values, and linked items
S FLDS="",ITMX=0,FILE=$P(^CIAZG(19950.41,GRU,0),U,2),IEN=+IENS
F S ITMX=$O(ITEMS("C",GRU,ITMX)) Q:'ITMX D
.S LINK=$P(ITEMS(ITMX,0),U,3)
.S X=ITEMS(ITMX,-1),TYPE=+$P(X,U,4),LINK=$S(LINK:$P(X,U,6),1:0)
.Q:TYPE>1
.S VALS(ITMX,"I")="",VALS(ITMX,"E")=""
.S:LINK LINK(ITMX)=LINK
.S Y=$O(CACHE("B",+ITEMS(ITMX),""))
.I Y M VALS(ITMX)=CACHE(Y) Q
.S TYPE(TYPE,ITMX)=""
.I 'TYPE D
..S X=$P(X,U,5)
..I 'X S (VALS(ITMX,"I"),VALS(ITMX,"E"))=IEN
..E S FLDS=FLDS_$S($L(FLDS):";",1:"")_X
; Fetch field values and move into ITEMS array
S DATA=$$TMPGBL^CIAZGUTL("FETCH")
D:$L(FLDS) GETS^DIQ(FILE,IENS,FLDS,"IE",DATA)
S ITMX=0
F S ITMX=$O(TYPE(0,ITMX)) Q:'ITMX D
.N X,Y,Z
.S X=$P(ITEMS(ITMX,-1),U,5),Y=$O(@DATA@(FILE,IENS,X,0))
.I 'Y M VALS(ITMX)=@DATA@(FILE,IENS,X)
.E D ; WP Field
..S (VALS(ITMX,"I"),VALS(ITMX,"E"))=@DATA@(FILE,IENS,X,Y)
..F S Y=$O(@DATA@(FILE,IENS,X,Y)) Q:'Y!(Y>10000) D
...S (VALS(ITMX,"I",Y-1),VALS(ITMX,"E",Y-1))=$S(Y=10000:"<DATA TRUNCATED",1:@DATA@(FILE,IENS,X,Y))
K @DATA
; Evaluate computed values and move into ITEMS array
S ITMX=0
F S ITMX=$O(TYPE(1,ITMX)) Q:'ITMX D
.N X
.X $G(^CIAZG(19950.42,+ITEMS(ITMX),20))
.S VALS(ITMX,"I")=$G(X("I"),$G(X))
.S VALS(ITMX,"E")=$G(X("E"),$G(X))
; Iterate over linked items
S ITMX=0
F S ITMX=$O(LINK(ITMX)) Q:'ITMX D
.S X=$G(VALS(ITMX,"I"))
.D:X FETCH(LINK(ITMX),X_",",.ITEMS,.VALS,.CACHE)
Q
;AUDIT file specific FETCH routine
FETCHAUD(GRU,IENS,ITEMS,VALS,CACHE) ;
N FILE,FLDS,TYPE,DATA,LINK,ITMX,ITM,IEN,X,Y
K DATA M DATA=^DIA(FILEIEN,AUDIEN)
; Build list of fields, computed values, and linked items
S FLDS="",ITMX=0,FILE=$P(^CIAZG(19950.41,GRU,0),U,2),IEN=+IENS
F S ITMX=$O(ITEMS("C",GRU,ITMX)) Q:'ITMX D
.S LINK=$P(ITEMS(ITMX,0),U,3)
.S X=ITEMS(ITMX,-1),TYPE=+$P(X,U,4),LINK=$S(LINK:$P(X,U,6),1:0)
.Q:TYPE>1
.S VALS(ITMX,"I")="",VALS(ITMX,"E")=""
.S:LINK LINK(ITMX)=LINK
.S Y=$O(CACHE("B",+ITEMS(ITMX),""))
.I Y M VALS(ITMX)=CACHE(Y) Q
.S TYPE(TYPE,ITMX)=""
.I 'TYPE D
..S X=$P(X,U,5)
..I 'X S (VALS(ITMX,"I"),VALS(ITMX,"E"))=IEN
..E D
...S VALS(ITMX,"I")=$$AUDINT(X)
...S VALS(ITMX,"E")=$$AUDEXT(X)
; Evaluate computed values and move into ITEMS array
S ITMX=0
F S ITMX=$O(TYPE(1,ITMX)) Q:'ITMX D
.N X
.X $G(^CIAZG(19950.42,+ITEMS(ITMX),20))
.S VALS(ITMX,"I")=$G(X("I"),$G(X))
.S VALS(ITMX,"E")=$G(X("E"),$G(X))
; Iterate over linked items
S ITMX=0
F S ITMX=$O(LINK(ITMX)) Q:'ITMX D
.S X=$G(VALS(ITMX,"I"))
.D:X FETCH(LINK(ITMX),X_",",.ITEMS,.VALS,.CACHE)
Q
;FETCH AUDIT internal values
AUDINT(FLD) ;EP-
N X
I FLD=".001" Q $P(IENS,",",2)
I FLD=".01" Q $P(DATA(0),U,1)
I FLD=".02" Q $P(DATA(0),U,2)
I FLD=".03" Q $P(DATA(0),U,3)
I FLD=".04" Q $P(DATA(0),U,4)
I FLD=".05" Q $P(DATA(0),U,5)
I FLD="1" Q $S($P(DATA(0),U,1)'="":$$GET1^DIQ(FILEIEN,$P(DATA(0),U,1),.01),1:"")
I FLD="1.1" Q $P(^DD(FILEIEN,$P($P(DATA(0),U,3),",",1),0),U,1)
I FLD="2" Q $G(DATA(2))
I FLD="2.1" Q $P($G(DATA(2.1)),U,1)
I FLD="2.2" Q $P($G(DATA(2.1)),U,2)
I FLD="3" Q $G(DATA(3))
I FLD="3.1" Q $P($G(DATA(3.1)),U,1)
I FLD="3.2" Q $P($G(DATA(3.1)),U,2)
I FLD="4.1" Q $P($G(DATA(4.1)),U,1)
I FLD="4.2" Q $P($G(DATA(4.1)),U,2)
I FLD=".06" Q $P(DATA(0),U,6)
I FLD="2.9" N X,D0 S DIA=+$P(IENS,",",1),D0=+$P(IENS,",",2) X ^DD(1.1,2.9,9.1) Q X
Q FLD_"intunk"
Q
;FETCH AUDIT external values
AUDEXT(FLD) S INTVAL=$$AUDINT(FLD)
;RETURN INTERNAL VALUES FOR FIELDS NOT NEEDING TRANSLATION
Q:(FLD=".001")!(FLD=".01")!(FLD=".03")!(FLD="1")!(FLD="1.1")!(FLD="2")!(FLD="2.1")!(FLD="3")!(FLD="3.1") INTVAL
;Get external values for other fields
I FLD=".02" S Y=INTVAL D DD^%DT Q Y
I FLD=".04" Q $$GET1^DIQ(200,INTVAL,".01")
I FLD=".05" Q $S(INTVAL="A":"Added Record",1:"")
I FLD=".06" Q $S(INTVAL="i":"Inquired",1:"")
I FLD="2" Q $S(INTVAL="":"<no previous value>",1:INTVAL)
I (FLD="2.2")!(FLD="3.2") Q $S(INTVAL="S":"Set",INTVAL="P":"Pointer",INTVAL="V":"Variable Pointer",1:"")
I FLD="3" Q $S(INTVAL="":"<deleted>",1:INTVAL)
I FLD="4.1" Q $$GET1^DIQ(19,INTVAL,".01")
I FLD="4.2" Q INTVAL ; THIS NEEDS TO DETERMINE HOW TO EVALUATE THIS "VARIABLE POINTER"
I FLD=2.9 Q $P($G(^DPT(+INTVAL,0)),U)
Q FLD_"exunk"
Q
CIAZGRU ;MSC/IND/DKM - Generic Retrieval Utility ;29-Aug-2011 13:52;PLS
+1 ;;1.4;GENERIC RETRIEVAL UTILITY;;Feb 14, 2008
+2 ;;Copyright 2000-2008, Medsphere Systems Corporation
+3 ;=================================================================
+4 ;Modification 09/03/2010;MSC/MMT;Implement specific code to handle the AUDIT file
+5 ; EP: Main entry point for user interaction
ENTRY NEW GRU,CRT,ABORT,WHEN
+1 SET GRU=$$GETIEN^CIAZGUTP(19950.41,"Select Retrieval: ","N X S X=^(0) I $P(X,U,3)=DUZ!$P(X,U,4)",.ABORT)
+2 IF $GET(ABORT)
QUIT
+3 DO GETCRT(GRU,.CRT,,.ABORT)
+4 IF $GET(ABORT)
QUIT
+5 SET WHEN=$$DIR^CIAZGUTP("DO^::FR","Run at what time","NOW",,.ABORT)
+6 IF '$GET(ABORT)
DO SUBMIT(GRU,WHEN,.CRT)
+7 QUIT
+8 ; EP: Submit a query
SUBMIT(GRU,WHEN,CRT,GBL) ;
+1 NEW SRT,PRT,RSLT
+2 DO GETITEMS(GRU,30,.SRT)
DO GETITEMS(GRU,40,.PRT)
+3 SET RSLT=$$SUBMIT2(GRU,.WHEN,.CRT,.SRT,.PRT,.GBL)
+4 IF $QUIT
QUIT RSLT
+5 QUIT
+6 ; EP: Submit a query (alternate entry)
SUBMIT2(GRU,WHEN,CRT,SRT,PRT,GBL) ;
+1 NEW FDA,RSLT,IEN
+2 SET RSLT=$$RSLTID^CIAZGUTL
SET IEN(1)=RSLT
+3 SET FDA=$NAME(FDA(19950.49,"+1,"))
+4 SET @FDA@(.01)=$$NOW^XLFDT
+5 SET @FDA@(1)=DUZ
+6 SET @FDA@(2)=$PIECE(^CIAZG(19950.41,GRU,0),U)
+7 SET @FDA@(5)=0
+8 SET @FDA@(7)=0
+9 SET @FDA@(8)=0
+10 SET @FDA@(9)=GRU
+11 DO UPDATE^DIE(,"FDA","IEN")
+12 IF '$GET(WHEN)
Begin DoDot:1
+13 DO TASK
End DoDot:1
+14 IF '$TEST
DO RSLTUPD^CIAZGUTL(RSLT,6,$$QUEUE^CIAUTSK("TASK^CIAZGRU","Generic Retrieval Query",.WHEN,"CRT(^SRT(^PRT(^RSLT^GRU^GBL"))
+15 IF $QUIT
QUIT RSLT
+16 QUIT
+17 ; EP: Taskman entry point
TASK NEW GBLRT,GBLS,ABORT,INTRV,X,$ETRAP,$ESTACK
+1 SET $ETRAP="D TASKERR^CIAZGRU"
SET ZTREQ="@"
+2 DO RSLTUPD^CIAZGUTL(RSLT,5,1,1)
+3 DO RSLTUPD^CIAZGUTL(RSLT,3,$$NOW^XLFDT)
+4 SET GBLRT=$NAME(^XTMP("CIAZGRU",RSLT))
SET (GBLS,PRT,ABORT)=0
SET INTRV=$$GET^XPAR("ALL","CIAZG UPDATE INTERVAL")
+5 IF INTRV<100
SET INTRV=100
+6 KILL @GBLRT
+7 SET @GBLRT@(0)=DT+10000_U_DT_U_GRU
+8 FOR X="CRT","SRT","PRT"
MERGE @GBLRT@(X)=@X
+9 DO OUTPRT($NAME(@GBLRT@("FLD")),GRU)
+10 DO RETRIEVE(GRU,.GBL,1)
+11 DO RSLTUPD^CIAZGUTL(RSLT,5,$SELECT(ABORT:3,1:2),1)
+12 DO RSLTUPD^CIAZGUTL(RSLT,4,$$NOW^XLFDT)
+13 QUIT
+14 ; Error handler for task
TASKERR DO ^%ZTER
DO RSLTUPD^CIAZGUTL(RSLT,5,5)
DO UNWIND^%ZTER
+1 QUIT
+2 ; Output field list to result global
+3 ; Format in output global is:
+4 ; Item Name^Width^Format^Datatype^Item IEN^Definition IEN^Multiple IEN
OUTPRT(GBL,GRU) ;
+1 NEW PRTX,LNK,ITM,FMT,TYP,WID,DTP,X
+2 SET PRTX=0
+3 FOR
SET PRTX=$ORDER(PRT("C",GRU,PRTX))
IF 'PRTX
QUIT
Begin DoDot:1
+4 SET X=PRT(PRTX,0)
SET LNK=$PIECE(X,U,3)
SET FMT=$PIECE(X,U,4)
SET WID=$PIECE(X,U,5)
+5 SET X=PRT(PRTX,-1)
SET ITM=$PIECE(X,U)
SET TYP=$PIECE(X,U,4)
SET DTP=$PIECE(X,U,7)
SET LNK=$SELECT(LNK:$PIECE(X,U,6),1:0)
+6 IF $LENGTH(FMT)
IF FMT'=2
IF TYP<2
SET @GBL@(PRTX)=ITM_U_WID_U_FMT_U_DTP_U_PRT(PRTX)
+7 IF 'LNK
QUIT
+8 IF TYP>1
Begin DoDot:2
+9 SET @GBL@(PRTX)=ITM
+10 DO OUTPRT($NAME(@GBL@(PRTX)),LNK)
End DoDot:2
+11 IF '$TEST
DO OUTPRT(GBL,LNK)
End DoDot:1
+12 QUIT
+13 ; Collect criteria for query
+14 ; GRU = GR Definition IEN
+15 ; .ARY = Array to receive data
+16 ; .VALS = Supplied values (optional)
+17 ; .ABORT= Abort flag (returned)
GETCRT(GRU,ARY,VALS,ABORT) ;
+1 NEW ARYX
+2 DO GETITEMS(GRU,20,.ARY)
+3 SET ARYX=0
+4 FOR
SET ARYX=$ORDER(ARY(ARYX))
IF 'ARYX
QUIT
Begin DoDot:1
+5 NEW GRU,VAL,LP,LPX,MLT,IENS
+6 SET GRU=+$PIECE(ARY(ARYX),U,2)
SET MLT=+$PIECE(ARY(ARYX),U,3)
SET IENS=MLT_","_GRU_","
+7 IF $DATA(VALS(IENS))
MERGE VAL=VALS(IENS)
+8 IF '$TEST
Begin DoDot:2
+9 SET (LP,LPX)=0
+10 FOR
SET LP=$ORDER(ARY(ARYX,10,LP))
IF 'LP
QUIT
SET LPX=LPX+1
SET VAL(LPX)=ARY(ARYX,10,LP,0)
+11 IF $PIECE(ARY(ARYX,0),U,6)
Begin DoDot:3
+12 NEW DTP,OPR,VTP,PROMPT
+13 MERGE PROMPT=ARY(ARYX,20)
+14 KILL PROMPT(0)
+15 SET DTP=+$PIECE(ARY(ARYX,-1),U,7)
SET OPR=+$PIECE(ARY(ARYX,0),U,5)
SET VTP=+$PIECE(ARY(ARYX,0),U,6)
+16 IF VTP
SET VTP=+$PIECE($GET(^CIAZG(19950.44,OPR,0)),U,2)
+17 IF VTP
XECUTE $GET(^CIAZG(19950.43,DTP,10,VTP,1))
End DoDot:3
End DoDot:2
+18 KILL ARY(ARYX,10),ARY(ARYX,20)
+19 IF '$DATA(VAL)!$GET(ABORT)
QUIT
+20 SET LP=0
+21 FOR
SET LP=$ORDER(VAL(LP))
IF 'LP
QUIT
IF $DATA(VAL(LP))#2
SET VAL("B",$SELECT($LENGTH(VAL(LP)):VAL(LP),1:$CHAR(1)))=""
+22 MERGE ARY(ARYX,"V")=VAL
End DoDot:1
IF $GET(ABORT)
QUIT
+23 IF $GET(ABORT)
KILL ARY
+24 QUIT
+25 ; Perform the retrieval
+26 ; GRU = GR Definition IEN
+27 ; IENS = IENS of subfile
+28 ; or global root for a join
+29 ; TOP = Flag indicating top level file
+30 ;
RETRIEVE(GRU,IENS,TOP) ;
+1 NEW IEN,FILE,ROOT,TMP,GBL,RTN,SRTL,CNT,TOT,FILEIEN,AUDIEN
+2 SET (RTN,GBLS)=GBLS+1
SET GBL=$NAME(@GBLRT@(GBLS))
SET TMP=$$TMPGBL^CIAZGUTL(GBLS)
SET TOP=+$GET(TOP)
SET IENS=$GET(IENS)
+3 SET FILE=$PIECE(^CIAZG(19950.41,GRU,0),U,2)
+4 IF $EXTRACT(IENS)=U
SET ROOT=IENS
SET IENS=""
+5 IF '$TEST
SET ROOT=$$ROOT^DILFD(FILE,","_IENS,1)
+6 SET (CNT,TOT,IEN,CNT(0))=0
SET TOT(0)=INTRV
+7 ;If processing the AUDIT file, branch to separate logic
+8 IF FILE="1.1"
GOTO RETAUDIT
+9 FOR
IF $$ABORT
QUIT
SET IEN=$ORDER(@ROOT@(IEN))
IF 'IEN
QUIT
Begin DoDot:1
+10 NEW CRTV,PRTV,SRTV,IENX
+11 IF TOP
IF TOT'<TOT(0)
DO UPDCNT
+12 SET IENX=IEN_","_IENS
SET TOT=TOT+1
+13 DO FETCH(GRU,IENX,.CRT,.CRTV)
+14 IF '$$SCREEN(.CRT,.CRTV)
QUIT
+15 IF TOP
SET @GBLRT@("IEN",IEN)=""
+16 SET CNT=CNT+1
+17 DO FETCH(GRU,IENX,.PRT,.PRTV,.CRTV)
+18 DO FETCH(GRU,IENX,.SRT,.SRTV,.PRTV)
+19 IF '$DATA(SRTL)
DO BLDSRT
+20 DO SUBFIL(GRU,IENX)
+21 DO SORT
End DoDot:1
+22 DO MOVE
+23 IF TOP
DO UPDCNT
+24 IF $QUIT
QUIT RTN
+25 QUIT
+26 ;Handle AUDIT file differently due to different IEN structure (^DIA(File#,IEN,...))
RETAUDIT ;
+1 SET (FILEIEN,AUDIEN)=0
+2 FOR
IF $$ABORT
QUIT
SET FILEIEN=$ORDER(@ROOT@(FILEIEN))
IF 'FILEIEN
QUIT
SET AUDIEN=0
Begin DoDot:1
+3 IF '$DATA(CRT(2))
IF $DATA(CRT(1,"V",1))
IF $DATA(CRT(1,"V",2))
IF $GET(CRT(1,-1))["DATE/TIME RECOR"
Begin DoDot:2
+4 NEW MSCI,MSCEND
SET MSCI=CRT(1,"V",1)-.01
SET MSCEND=$SELECT(CRT(1,"V",2)[".":CRT(1,"V",2),1:CRT(1,"V",2)+.9)
FOR
SET MSCI=$ORDER(@ROOT@(FILEIEN,"C",MSCI))
IF ('MSCI)!(MSCI>MSCEND)
QUIT
Begin DoDot:3
+5 SET AUDIEN=0
FOR
IF $$ABORT
QUIT
SET AUDIEN=$ORDER(@ROOT@(FILEIEN,"C",MSCI,AUDIEN))
IF 'AUDIEN
QUIT
DO MSC
End DoDot:3
End DoDot:2
QUIT
+6 FOR
IF $$ABORT
QUIT
SET AUDIEN=$ORDER(@ROOT@(FILEIEN,AUDIEN))
IF 'AUDIEN
QUIT
DO MSC
End DoDot:1
+7 DO MOVE
+8 IF TOP
DO UPDCNT
+9 IF $QUIT
QUIT RTN
+10 QUIT
MSC SET IEN=FILEIEN_","_AUDIEN
+1 NEW CRTV,PRTV,SRTV,IENX
+2 IF TOP
IF TOT'<TOT(0)
DO UPDCNT
+3 SET IENX=IEN_","_IENS
SET TOT=TOT+1
+4 DO FETCHAUD(GRU,IENX,.CRT,.CRTV)
+5 IF '$$SCREEN(.CRT,.CRTV)
QUIT
+6 IF TOP
SET @GBLRT@("IEN",IEN)=""
+7 SET CNT=CNT+1
+8 DO FETCHAUD(GRU,IENX,.PRT,.PRTV,.CRTV)
+9 DO FETCHAUD(GRU,IENX,.SRT,.SRTV,.PRTV)
+10 IF '$DATA(SRTL)
DO BLDSRT
+11 DO SUBFIL(GRU,IENX)
+12 DO SORT
+13 QUIT
+14 ; Update counts in result file
UPDCNT IF CNT'=CNT(0)
DO RSLTUPD^CIAZGUTL(RSLT,7,CNT,1)
+1 DO RSLTUPD^CIAZGUTL(RSLT,8,TOT)
+2 SET TOT(0)=TOT\INTRV*INTRV+INTRV
SET CNT(0)=CNT
+3 QUIT
+4 ; Returns true if task should abort
ABORT() IF ABORT
QUIT 1
+1 IF $$S^%ZTLOAD
SET ABORT=1
+2 IF $$RSLTSTA^CIAZGUTL(RSLT)>2
SET ABORT=1
+3 QUIT ABORT
+4 ; Iterate over subfiles
SUBFIL(GRU,IENS) ;
+1 NEW PRTX,LINK,TYPE,X
+2 SET PRTX=0
+3 FOR
SET PRTX=$ORDER(PRT("C",GRU,PRTX))
IF 'PRTX
QUIT
Begin DoDot:1
+4 SET LINK=$PIECE(PRT(PRTX,0),U,3)
SET TYPE=$PIECE(PRT(PRTX,-1),U,4)
+5 IF LINK
SET LINK=$PIECE(PRT(PRTX,-1),U,6)
+6 IF 'LINK
QUIT
+7 IF TYPE=2
Begin DoDot:2
+8 SET X=$$RETRIEVE(LINK,IENS)
SET PRTV(PRTX,"I")=X
SET PRTV(PRTX,"E")=X
End DoDot:2
+9 IF '$TEST
IF TYPE=3
Begin DoDot:2
+10 XECUTE ^CIAZG(19950.42,+PRT(PRTX),20)
+11 SET X=$$RETRIEVE(LINK,X)
SET PRTV(PRTX,"I")=X
SET PRTV(PRTX,"E")=X
End DoDot:2
+12 IF '$TEST
IF $GET(PRTV(PRTX,"I"))
DO SUBFIL(LINK,PRTV(PRTX,"I")_",")
End DoDot:1
+13 QUIT
+14 ; Apply screening criteria. Returns true if all criteria met.
SCREEN(CRT,CRTV) ;EP-
+1 NEW CRTX,OK,FLG,NEG
+2 SET CRTX=0
SET (FLG,OK)=1
+3 FOR
SET CRTX=$ORDER(CRTV(CRTX))
IF 'CRTX
QUIT
Begin DoDot:1
+4 NEW VAL,OPR,EXE,DTP,OR,X,Y
+5 SET Y=CRT(CRTX,0)
SET ITM=+CRT(CRTX)
SET OPR=$PIECE(Y,U,5)
SET OR=$PIECE(Y,U,4)
SET NEG=$PIECE(Y,U,7)
SET DTP=$PIECE(CRT(CRTX,-1),U,7)
+6 IF 'OPR
QUIT
+7 IF 'FLG
IF OK=OR
QUIT
+8 SET X=CRTV(CRTX,"I")
SET X("I")=X
SET X("E")=CRTV(CRTX,"E")
+9 MERGE VAL=CRT(CRTX,"V")
+10 SET VAL(1)=$GET(VAL(1))
SET VAL(2)=$GET(VAL(2))
+11 IF 1
+12 XECUTE $GET(^CIAZG(19950.43,DTP,20,OPR,1))
+13 SET Y=$SELECT(NEG:'$TEST,1:$TEST)
+14 IF FLG
SET OK=Y
SET FLG=0
+15 IF '$TEST
IF OR
SET OK=OK!Y
+16 IF '$TEST
SET OK=OK&Y
End DoDot:1
+17 QUIT OK
+18 ; Build list of sort items
BLDSRT SET SRTL=0
+1 FOR
SET SRTL=$ORDER(SRTV(SRTL))
IF 'SRTL
QUIT
SET SRTL(SRTL)=$SELECT($PIECE($GET(SRT(SRTL,0)),U,5):-1,1:1)
+2 SET SRTL(999999999999)=1
+3 QUIT
+4 ; Save the result of a single record retrieval in sort order
+5 ; Result saved as
+6 ; @TMP@(S1,S2...,Sn,N,S)
+7 ; where Sn = sort field values
+8 ; N = sequence # within identical sort values
+9 ; S = sequence # in PRT control array
SORT NEW KEY,VAL,FMT,SRTX,KEYX,PRTX
+1 SET SRTX=0
SET KEY=TMP
+2 FOR
SET SRTX=$ORDER(SRTV(SRTX))
IF 'SRTX
QUIT
Begin DoDot:1
+3 SET FMT=$PIECE(SRT(SRTX,0),U,4)
+4 SET VAL=$GET(SRTV(SRTX,$SELECT(FMT:"E",1:"I")))
+5 IF VAL=""
SET VAL=$CHAR(0)
+6 SET KEY=$NAME(@KEY@(VAL))
End DoDot:1
+7 SET KEYX=$ORDER(@KEY@(""),-1)+1
SET PRTX=0
+8 FOR
SET PRTX=$ORDER(PRTV(PRTX))
IF 'PRTX
QUIT
Begin DoDot:1
+9 SET FMT=$PIECE(PRT(PRTX,0),U,4)
+10 IF $PIECE(PRT(PRTX,-1),U,4)>1
SET FMT=0
+11 IF $LENGTH(FMT)&(FMT'=2)
MERGE @KEY@(KEYX,PRTX)=PRTV(PRTX,$SELECT(FMT:"E",1:"I"))
End DoDot:1
+12 QUIT
+13 ; Move sorted results into target global
+14 ; Iterates over each sort value in ascending or descending order
MOVE NEW GBLX
+1 SET GBLX=0
+2 DO MOVEX(TMP,0)
+3 KILL @TMP
+4 QUIT
+5 ; Recurse over each sort subscript.
MOVEX(TMP,SRTX) ;
+1 NEW ORD,NXT
+2 SET SRTX=$ORDER(SRTL(SRTX))
+3 IF 'SRTX
IF $DATA(@TMP)
Begin DoDot:1
+4 SET GBLX=GBLX+1
+5 MERGE @GBL@(GBLX)=@TMP
End DoDot:1
QUIT
+6 SET ORD=SRTL(SRTX)
SET NXT=""
+7 FOR
SET NXT=$ORDER(@TMP@(NXT),ORD)
IF '$LENGTH(NXT)
QUIT
Begin DoDot:1
+8 DO MOVEX($NAME(@TMP@(NXT)),SRTX)
End DoDot:1
+9 QUIT
+10 ; Build item array from multiple
+11 ; GRU = IEN of GR Definition
+12 ; NODE = Multiple root node
+13 ; ARY = Local array to receive data
+14 ; where N = sequence #
+15 ; I = IEN of GR Item
+16 ; D = IEN of GR Definiton
+17 ; M = IEN in multiple
+18 ; ARY(N) = I^D^M
+19 ; ARY(N,-1) = 0 node of GR Item entry
+20 ; ARY(N,x) = x node of multiple
+21 ; ARY("B",I,N) = xref
+22 ; ARY("C",D,N) = xref
GETITEMS(GRU,NODE,ARY,ARYX) ;
+1 NEW SEQ,MLT,ITM,LNK
+2 SET SEQ=""
SET ARYX=+$GET(ARYX)
+3 FOR
SET SEQ=$ORDER(^CIAZG(19950.41,GRU,NODE,"B",SEQ))
SET MLT=0
IF '$LENGTH(SEQ)
QUIT
Begin DoDot:1
+4 FOR
SET MLT=$ORDER(^CIAZG(19950.41,GRU,NODE,"B",SEQ,MLT))
IF 'MLT
QUIT
Begin DoDot:2
+5 SET ARYX=ARYX+1
+6 MERGE ARY(ARYX)=^CIAZG(19950.41,GRU,NODE,MLT)
+7 SET ITM=$PIECE(ARY(ARYX,0),U,2)
SET ARY("B",ITM,ARYX)=""
SET ARY("C",GRU,ARYX)=""
+8 SET ARY(ARYX)=ITM_U_GRU_U_MLT
SET ARY(ARYX,-1)=^CIAZG(19950.42,ITM,0)
+9 SET LNK=$PIECE(ARY(ARYX,0),U,3)
+10 IF LNK
SET LNK=$PIECE(ARY(ARYX,-1),U,6)
+11 IF LNK
DO GETITEMS(LNK,NODE,.ARY,.ARYX)
End DoDot:2
End DoDot:1
+12 QUIT
+13 ; Fetch specified items
+14 ; GRU = GR Definition IEN
+15 ; IENS = IENS of entry to fetch
+16 ; .ITEMS= Items control array
+17 ; .VALS = Array to receive values
+18 ; .CACHE= Array of cached values (optional)
FETCH(GRU,IENS,ITEMS,VALS,CACHE) ;
+1 NEW FILE,FLDS,TYPE,DATA,LINK,ITMX,ITM,IEN,X,Y
+2 ; Build list of fields, computed values, and linked items
+3 SET FLDS=""
SET ITMX=0
SET FILE=$PIECE(^CIAZG(19950.41,GRU,0),U,2)
SET IEN=+IENS
+4 FOR
SET ITMX=$ORDER(ITEMS("C",GRU,ITMX))
IF 'ITMX
QUIT
Begin DoDot:1
+5 SET LINK=$PIECE(ITEMS(ITMX,0),U,3)
+6 SET X=ITEMS(ITMX,-1)
SET TYPE=+$PIECE(X,U,4)
SET LINK=$SELECT(LINK:$PIECE(X,U,6),1:0)
+7 IF TYPE>1
QUIT
+8 SET VALS(ITMX,"I")=""
SET VALS(ITMX,"E")=""
+9 IF LINK
SET LINK(ITMX)=LINK
+10 SET Y=$ORDER(CACHE("B",+ITEMS(ITMX),""))
+11 IF Y
MERGE VALS(ITMX)=CACHE(Y)
QUIT
+12 SET TYPE(TYPE,ITMX)=""
+13 IF 'TYPE
Begin DoDot:2
+14 SET X=$PIECE(X,U,5)
+15 IF 'X
SET (VALS(ITMX,"I"),VALS(ITMX,"E"))=IEN
+16 IF '$TEST
SET FLDS=FLDS_$SELECT($LENGTH(FLDS):";",1:"")_X
End DoDot:2
End DoDot:1
+17 ; Fetch field values and move into ITEMS array
+18 SET DATA=$$TMPGBL^CIAZGUTL("FETCH")
+19 IF $LENGTH(FLDS)
DO GETS^DIQ(FILE,IENS,FLDS,"IE",DATA)
+20 SET ITMX=0
+21 FOR
SET ITMX=$ORDER(TYPE(0,ITMX))
IF 'ITMX
QUIT
Begin DoDot:1
+22 NEW X,Y,Z
+23 SET X=$PIECE(ITEMS(ITMX,-1),U,5)
SET Y=$ORDER(@DATA@(FILE,IENS,X,0))
+24 IF 'Y
MERGE VALS(ITMX)=@DATA@(FILE,IENS,X)
+25 ; WP Field
IF '$TEST
Begin DoDot:2
+26 SET (VALS(ITMX,"I"),VALS(ITMX,"E"))=@DATA@(FILE,IENS,X,Y)
+27 FOR
SET Y=$ORDER(@DATA@(FILE,IENS,X,Y))
IF 'Y!(Y>10000)
QUIT
Begin DoDot:3
+28 SET (VALS(ITMX,"I",Y-1),VALS(ITMX,"E",Y-1))=$SELECT(Y=10000:"<DATA TRUNCATED",1:@DATA@(FILE,IENS,X,Y))
End DoDot:3
End DoDot:2
End DoDot:1
+29 KILL @DATA
+30 ; Evaluate computed values and move into ITEMS array
+31 SET ITMX=0
+32 FOR
SET ITMX=$ORDER(TYPE(1,ITMX))
IF 'ITMX
QUIT
Begin DoDot:1
+33 NEW X
+34 XECUTE $GET(^CIAZG(19950.42,+ITEMS(ITMX),20))
+35 SET VALS(ITMX,"I")=$GET(X("I"),$GET(X))
+36 SET VALS(ITMX,"E")=$GET(X("E"),$GET(X))
End DoDot:1
+37 ; Iterate over linked items
+38 SET ITMX=0
+39 FOR
SET ITMX=$ORDER(LINK(ITMX))
IF 'ITMX
QUIT
Begin DoDot:1
+40 SET X=$GET(VALS(ITMX,"I"))
+41 IF X
DO FETCH(LINK(ITMX),X_",",.ITEMS,.VALS,.CACHE)
End DoDot:1
+42 QUIT
+43 ;AUDIT file specific FETCH routine
FETCHAUD(GRU,IENS,ITEMS,VALS,CACHE) ;
+1 NEW FILE,FLDS,TYPE,DATA,LINK,ITMX,ITM,IEN,X,Y
+2 KILL DATA
MERGE DATA=^DIA(FILEIEN,AUDIEN)
+3 ; Build list of fields, computed values, and linked items
+4 SET FLDS=""
SET ITMX=0
SET FILE=$PIECE(^CIAZG(19950.41,GRU,0),U,2)
SET IEN=+IENS
+5 FOR
SET ITMX=$ORDER(ITEMS("C",GRU,ITMX))
IF 'ITMX
QUIT
Begin DoDot:1
+6 SET LINK=$PIECE(ITEMS(ITMX,0),U,3)
+7 SET X=ITEMS(ITMX,-1)
SET TYPE=+$PIECE(X,U,4)
SET LINK=$SELECT(LINK:$PIECE(X,U,6),1:0)
+8 IF TYPE>1
QUIT
+9 SET VALS(ITMX,"I")=""
SET VALS(ITMX,"E")=""
+10 IF LINK
SET LINK(ITMX)=LINK
+11 SET Y=$ORDER(CACHE("B",+ITEMS(ITMX),""))
+12 IF Y
MERGE VALS(ITMX)=CACHE(Y)
QUIT
+13 SET TYPE(TYPE,ITMX)=""
+14 IF 'TYPE
Begin DoDot:2
+15 SET X=$PIECE(X,U,5)
+16 IF 'X
SET (VALS(ITMX,"I"),VALS(ITMX,"E"))=IEN
+17 IF '$TEST
Begin DoDot:3
+18 SET VALS(ITMX,"I")=$$AUDINT(X)
+19 SET VALS(ITMX,"E")=$$AUDEXT(X)
End DoDot:3
End DoDot:2
End DoDot:1
+20 ; Evaluate computed values and move into ITEMS array
+21 SET ITMX=0
+22 FOR
SET ITMX=$ORDER(TYPE(1,ITMX))
IF 'ITMX
QUIT
Begin DoDot:1
+23 NEW X
+24 XECUTE $GET(^CIAZG(19950.42,+ITEMS(ITMX),20))
+25 SET VALS(ITMX,"I")=$GET(X("I"),$GET(X))
+26 SET VALS(ITMX,"E")=$GET(X("E"),$GET(X))
End DoDot:1
+27 ; Iterate over linked items
+28 SET ITMX=0
+29 FOR
SET ITMX=$ORDER(LINK(ITMX))
IF 'ITMX
QUIT
Begin DoDot:1
+30 SET X=$GET(VALS(ITMX,"I"))
+31 IF X
DO FETCH(LINK(ITMX),X_",",.ITEMS,.VALS,.CACHE)
End DoDot:1
+32 QUIT
+33 ;FETCH AUDIT internal values
AUDINT(FLD) ;EP-
+1 NEW X
+2 IF FLD=".001"
QUIT $PIECE(IENS,",",2)
+3 IF FLD=".01"
QUIT $PIECE(DATA(0),U,1)
+4 IF FLD=".02"
QUIT $PIECE(DATA(0),U,2)
+5 IF FLD=".03"
QUIT $PIECE(DATA(0),U,3)
+6 IF FLD=".04"
QUIT $PIECE(DATA(0),U,4)
+7 IF FLD=".05"
QUIT $PIECE(DATA(0),U,5)
+8 IF FLD="1"
QUIT $SELECT($PIECE(DATA(0),U,1)'="":$$GET1^DIQ(FILEIEN,$PIECE(DATA(0),U,1),.01),1:"")
+9 IF FLD="1.1"
QUIT $PIECE(^DD(FILEIEN,$PIECE($PIECE(DATA(0),U,3),",",1),0),U,1)
+10 IF FLD="2"
QUIT $GET(DATA(2))
+11 IF FLD="2.1"
QUIT $PIECE($GET(DATA(2.1)),U,1)
+12 IF FLD="2.2"
QUIT $PIECE($GET(DATA(2.1)),U,2)
+13 IF FLD="3"
QUIT $GET(DATA(3))
+14 IF FLD="3.1"
QUIT $PIECE($GET(DATA(3.1)),U,1)
+15 IF FLD="3.2"
QUIT $PIECE($GET(DATA(3.1)),U,2)
+16 IF FLD="4.1"
QUIT $PIECE($GET(DATA(4.1)),U,1)
+17 IF FLD="4.2"
QUIT $PIECE($GET(DATA(4.1)),U,2)
+18 IF FLD=".06"
QUIT $PIECE(DATA(0),U,6)
+19 IF FLD="2.9"
NEW X,D0
SET DIA=+$PIECE(IENS,",",1)
SET D0=+$PIECE(IENS,",",2)
XECUTE ^DD(1.1,2.9,9.1)
QUIT X
+20 QUIT FLD_"intunk"
+21 QUIT
+22 ;FETCH AUDIT external values
AUDEXT(FLD) SET INTVAL=$$AUDINT(FLD)
+1 ;RETURN INTERNAL VALUES FOR FIELDS NOT NEEDING TRANSLATION
+2 IF (FLD=".001")!(FLD=".01")!(FLD=".03")!(FLD="1")!(FLD="1.1")!(FLD="2")!(FLD="2.1")!(FLD="3")!(FLD="3.1")
QUIT INTVAL
+3 ;Get external values for other fields
+4 IF FLD=".02"
SET Y=INTVAL
DO DD^%DT
QUIT Y
+5 IF FLD=".04"
QUIT $$GET1^DIQ(200,INTVAL,".01")
+6 IF FLD=".05"
QUIT $SELECT(INTVAL="A":"Added Record",1:"")
+7 IF FLD=".06"
QUIT $SELECT(INTVAL="i":"Inquired",1:"")
+8 IF FLD="2"
QUIT $SELECT(INTVAL="":"<no previous value>",1:INTVAL)
+9 IF (FLD="2.2")!(FLD="3.2")
QUIT $SELECT(INTVAL="S":"Set",INTVAL="P":"Pointer",INTVAL="V":"Variable Pointer",1:"")
+10 IF FLD="3"
QUIT $SELECT(INTVAL="":"<deleted>",1:INTVAL)
+11 IF FLD="4.1"
QUIT $$GET1^DIQ(19,INTVAL,".01")
+12 ; THIS NEEDS TO DETERMINE HOW TO EVALUATE THIS "VARIABLE POINTER"
IF FLD="4.2"
QUIT INTVAL
+13 IF FLD=2.9
QUIT $PIECE($GET(^DPT(+INTVAL,0)),U)
+14 QUIT FLD_"exunk"
+15 QUIT
