- DIQG ;SFISC/DCL - DATA RETRIEVAL PRIMITIVE ;7AUG2015
- ;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
- ;;Per VA Directive 6402, this routine should not be modified.
- ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- ;;Licensed under the terms of the Apache License, Version 2.0.
- ;
- GET(DIQGR,DA,DR,DIQGPARM,DIQGETA,DIQGERRA,DIQGIPAR) ; file,rec,fld,parm,targetarray,errarray,int
- DDENTRY I $G(U)'="^" N U S U="^" ;COME HERE FROM EN3+11^DIQGDD AS WELL AS GET1+4^DIQ
- I '$G(DA) N X S X(1)="RECORD" Q $$F(.X,2)
- S DIQGIPAR=$G(DIQGIPAR),DIQGPARM=$G(DIQGPARM)
- I 'DIQGIPAR N DIQGAUDR,DIQGAUDD S DIQGAUDD=+$P(DIQGPARM,"A",2) I DIQGAUDD D GET^DIAUTL(DIQGR,DA,DIQGAUDD,"DIQGAUDR")
- N DFF,DIQGSI,DIQGDD,DIQGWPB,DIQGWPO S DIQGDD=DIQGPARM["D",DIQGWPB=DIQGPARM["B"
- S DIQGWPO=1
- N DIQGEY S DIQGEY("FILE")=$G(DIQGR),DIQGEY("RECORD")=$G(DA),DIQGEY("FIELD")=$G(DR)
- I '$D(DIQGR) N X S X(1)="FILE" Q $$F(.X,1)
- I 'DIQGR,'DIQGIPAR N X S X(1)="FILE" Q $$F(.X,12)
- DA D:$G(DA)["," IEN(DA,.DA)
- I $G(DR)="" N X S X(1)="FIELD" Q $$F(.X,10)
- I 'DIQGIPAR,'DIQGDD Q:$$N9^DIQGU(DIQGR,.DA) $$F(.DIQGEY,16) I '$D(^DD(DIQGR)) N X S X(1)="FILE" Q $$F(.X,18)
- S DIQGETA=$G(DIQGETA) I DIQGETA["("&(DIQGETA'[")") N X S X(1)="TARGET ARRAY" Q $$F(.X,14)
- I DIQGR S DFF=DIQGR,DIQGR=$S(DIQGDD:$$DDROOT(DIQGR),1:$$ROOT^DIQGU(DIQGR,.DA)) I DIQGR="" N X S X(1)="FILE and/or IEN" Q $$F(.X,4)
- DFF S DIQGSI=$$CREF(DIQGR) I '$D(DFF) S DFF=+$P($G(@DIQGSI@(0)),U,2) I 'DFF,DIQGPARM'["D" N X S X("FILE")=DIQGSI Q $$F(.X,6) ;does the file exist?
- I '$D(@DIQGSI@(DA)),'DIQGIPAR,DIQGPARM'["A" Q $$F(.DIQGEY,19) ;Entry may have existed audited in the past
- I '$G(DT) N DT S DT=$$DT^DIQGU($H)
- N DIQGPI,DIQGZN S DIQGPI=DIQGPARM["I",DIQGZN=DIQGPARM["Z"
- N %,%H,%T,I,J,N,X
- D0 S X=0,N="D0" F S X=$O(DA(X)) Q:X'>0 S I=X,N=N_",D"_X
- N @N
- S @("D"_+$G(I)_"=DA") I $G(I) F J=I-1:-1:0 S @("D"_J_"=DA(I-J)")
- N C,P,Y,DIQGDN,DIQGD4,DIQGDRN
- S (X,Y)="",DIQGDRN=DR
- DD S DIQGDN="^DD("_$S(DIQGPARM["D":0,1:DFF)_")" ;name of ^DD
- FIELD I DR'?.N,$D(@DIQGDN@("B",DR)) S DIQGDRN=$O(^(DR,"")) I $O(^(DIQGDRN)) N X S X("FILE")=DIQGDN,X(1)=DR Q $$F(.X,15)
- I DIQGDD,DIQGDRN'>0 D I $E(DIQGDRN,1,6)="$$$ NO" N X S X(1)="ATTRIBUTE" Q $$F(.X,17)
- .S DIQGDRN=$$DDN^DIQGU0(DR) Q:$E(DIQGDRN,1,6)="$$$ NO"
- .S DIQGDN="^DD("_$P(DIQGDRN,"^")_")",DIQGDRN=$P(DIQGDRN,"^",2)
- I DIQGDRN>0,$D(@DIQGDN@(DIQGDRN,0)) S DIQGD4=$P(^(0),"^",4),C=$P(^(0),"^",2),P=$P(DIQGD4,";") G:$P(DIQGD4,";",2)'>0 DIQ S Y=$P($G(@DIQGSI@(DA,P)),"^",$P(DIQGD4,";",2)) G DIQ
- TRYCOMP N X,DIQGS I 'DIQGIPAR D EXPR(DFF,DR) ;DON'T ALLOW COMPUTED EXPRESSIONS EXCEPT FROM $$GET1^DIQ
- I $D(X) S C=Y G C:C["m" D CMPAUD(DR,$G(X("USED"))) I $D(X) X X Q X
- GIVEUP Q $$F(.DIQGEY,7)
- ;
- DIQ I DIQGDRN=.001 S Y=DA ;AT THIS POINT, 'Y' IS THE VALUE OF THE ATTRIBUTE WE WANT
- G BMW:C,REAL:C'["C"
- C I C["m" N X D G:'$D(X) FE Q:DIQGWPO $NA(@DIQGETA) Q "" ;S X(1)="MULTILINE COMPUTED" Q $$F(.X,3)
- .N D,DICMX
- .I DIQGETA="" S X(1)="TARGET ARRAY for the MULTI-LINE COMPUTED FIELD" D BLD^DIALOG(202,.X) K X Q
- .S DICMX="S @DIQGETA@(D"_$S(DIQGZN:",0",1:"")_")=X" ;"Z" PARAMETER SAYS TO PUT ZERO NODES IN MULTIPLE
- .X $P(@DIQGDN@(DIQGDRN,0),U,5,999) ;XECUTE COMPUTED MULTIPLE
- I DIQGDN="^DD(1.005)",DIQGDRN=1 S X=@DIQGSI@(DA,0)
- N DCC,DIQGH,X,DFF S DIQGH=$G(DIERR),DCC=DIQGR,DFF=+$P(DCC,"(",2)
- I $D(@DIQGDN@(DIQGDRN,9.01)),$D(^(9.1)) D CMPAUD(^(9.1),^(9.01)) I $D(X) X X I 1
- E S X="" X $P(@DIQGDN@(DIQGDRN,0),"^",5,999) ;HELLEVI
- D:DIQGH'=$G(DIERR)
- .N X
- .D BLD^DIALOG(120,"FIELD")
- I $G(X)=""!DIQGPI Q $G(X)
- CP I C["p",X S C=+$P(C,"p",2) I C,$D(^DIC(C,0,"GL")),$D(@(^("GL")_"0)")),$D(^(X,0)) Q $$EXTERNAL^DIDU(C,.01,"",$P(^(0),U))
- Q $S(C["D":$$DATE^DIUTL(X),1:X) ;***
- ;
- REAL I $E($P(DIQGD4,";",2))="E" S Y=$E($G(@DIQGSI@(DA,P)),$E($P($P(DIQGD4,";",2),","),2,99),$P($P(DIQGD4,";",2),",",2)) S:Y?." " Y="" ;SPACES ARE NULL
- AUDIT I $G(DIQGAUDD) D ;Is there an AUDIT TRAIL for the field?
- .I $G(DIQGAUDR(DFF,$$DA^DIQGQ(.DA))) S Y="" Q ;If entry was created after DIQGAUDD, we know there were no FIELD values!
- .S P=$G(DIQGAUDR(DFF,$$DA^DIQGQ(.DA),DIQGDRN))
- .I P S Y=$$DIA^DIAUTL(DIQGAUDD,DIQGAUDR,P)
- .Q:C'["P"!'Y N F S F=+$P(C,"P",2) Q:F=DIQGEY("FILE")&(Y=DA)
- .S Y=$$GET1^DIQ(F,Y_",",.01,"A"_DIQGAUDD),C=$TR(C,"PO") ;Recurse to get old POINTER value (as long as recursion isn't infinite!)
- OUT I 'DIQGPI&(C["O"!(C["S")!(C["P")!(C["V")!(C["D")!(C["t"))&($D(@DIQGDN@(DIQGDRN,0))) S C=$P(^(0),"^",2) Q $$EXTERNAL^DIDU(+$P(DIQGDN,"(",2),DIQGDRN,"A",Y) ;"ALLOW" bad data
- Q $G(Y)
- ;
- BMW ;PUT WORD-PROCESSING FIELD INTO @DIQGETA
- I C,$P(^DD(+C,.01,0),"^",2)["W" Q:DIQGWPB "$CREF$"_DIQGR_DA_","_$$Q^DIQGU(P)_")" D G:X="" FE Q:DIQGWPO $NA(@DIQGETA) Q:DIQGIPAR "$WP$" Q ""
- .I DIQGETA']"" K X S X(1)="TARGET ARRAY" D BLD^DIALOG(202,.X) S X="" Q
- .S X=DIQGR_DA_","_$$Q^DIQGU(P)_")"
- .I '$O(@X@(0)) S X="" Q
- .I DIQGZN M @DIQGETA=@X K @DIQGETA@(0) Q
- .S Y=0 F S Y=$O(@X@(Y)) Q:Y'>0 I $D(^(Y,0)) S @DIQGETA@(Y)=^(0)
- .Q
- I C,$P(^DD(+C,.01,0),"^",2)["M" Q $$F(.DIQGEY,11)
- I DIQGPI!(DIQGDD) Q $G(Y)
- Q $$F(.DIQGEY,8)
- CREF(X) N L,X1,X2,X3 S X1=$P(X,"("),X2=$P(X,"(",2,99),L=$L(X2),X3=$TR($E(X2,L),",)"),X2=$E(X2,1,(L-1))_X3 Q X1_$S(X2]"":"("_X2_")",1:"")
- WP(DIQGSA,DIQGTA,DIQGZN,DIQGP) N DIQG S DIQG=0 F S DIQG=$O(@DIQGSA@(DIQG)) Q:DIQG'>0 I $D(^(DIQG,0)) S @$S(DIQGZN:"@DIQGTA@(DIQG,0)",1:"@DIQGTA@(DIQG)")=^(0)
- Q:DIQGP "$WP$" Q ""
- DY(Y) Q $$DATE^DIUTL(Y) ;***
- IEN(IEN,DA) S DA=$P(IEN,",") N I F I=2:1 Q:$P(IEN,",",I)="" S DA(I-1)=$P(IEN,",",I)
- Q
- DDROOT(X) Q:'$D(^DD(X)) "" Q "^DD("_X_","
- ;
- CMPAUD(DEXPR,DIQGS) ;DEXPR is Expression, DIQGS is string of Fields used
- Q:'$G(DIQGAUDD)
- N I,F,FD,A
- F I=1:1 S F=$P(DIQGS,";",I) Q:F="" D
- .S A=$G(DIQGAUDR(+F,$$DA^DIQGQ(.DA),$P(F,U,2)))
- .I A S DIQGS(1,+F,$P(F,U,2))=""""_$$CONVQQ^DILIBF($$DIA^DIAUTL(DIQGAUDD,+F,A))_""""
- S DIQGS("TODAY")=DIQGAUDD\1,DIQGS("TODAY","DATE")=1,DIQGS("NOW")=DIQGAUDD,DIQGS("NOW","DATE")=1 ;'TODAY' is the old date!
- ;now we call DICOMP with old (audit) values plugged in to the field's Computed Expression --
- D EXPR(DIQGAUDR,DEXPR)
- Q
- EXPR(DIFILE,DIEXPR) I DIQGPI K X Q:$TR(DIEXPR," 1234567890.?")="" S DIEXPR="INTERNAL("_DIEXPR_")"
- D EXPR^DICOMP(DIFILE,"",DIEXPR,.DIQGS)
- I 'DIQGPI,$G(Y)["D",Y'["m",$D(X)#2 S X=X_" S X=$$DATE^DIUTL(X)"
- Q
- ;
- F(DIQGEY,X) D BLD^DIALOG($P($T(TXT+X),";",4),.DIQGEY)
- FE I $G(DIQGERRA)]"" D CALLOUT^DIEFU(DIQGERRA)
- Q ""
- TXT ;;
- ;;file root/ref invalid;202;1
- ;;record invalid;202;2
- ;;multiline computed;520;3
- ;;file ref invalid;202;4
- ;;field name/number invalid;202;5
- ;;DD ref for file/field invalid;401;6
- ;;unable to find field name;200;7
- ;;unable to identify type of data in DD;510;8
- ;;unable to resolve extended ref;501;9
- ;;field ref missing;202;10
- ;;multiple field - invalid parameters;309;11
- ;;file number not passed or invalid;202;12
- ;;;;13
- ;;invalid target array;202;14
- ;;ambiguous field name;505;15
- ;;record unavailable;602;16
- ;;invalid attribute;202;17
- ;;file not found;202;18
- ;;record entry does not exist;601;19
- ;;;;20
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIQG 7138 printed Feb 19, 2025@00:19:49 Page 2
- DIQG ;SFISC/DCL - DATA RETRIEVAL PRIMITIVE ;7AUG2015
- +1 ;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- +4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- +5 ;;Licensed under the terms of the Apache License, Version 2.0.
- +6 ;
- GET(DIQGR,DA,DR,DIQGPARM,DIQGETA,DIQGERRA,DIQGIPAR) ; file,rec,fld,parm,targetarray,errarray,int
- DDENTRY ;COME HERE FROM EN3+11^DIQGDD AS WELL AS GET1+4^DIQ
- IF $GET(U)'="^"
- NEW U
- SET U="^"
- +1 IF '$GET(DA)
- NEW X
- SET X(1)="RECORD"
- QUIT $$F(.X,2)
- +2 SET DIQGIPAR=$GET(DIQGIPAR)
- SET DIQGPARM=$GET(DIQGPARM)
- +3 IF 'DIQGIPAR
- NEW DIQGAUDR,DIQGAUDD
- SET DIQGAUDD=+$PIECE(DIQGPARM,"A",2)
- IF DIQGAUDD
- DO GET^DIAUTL(DIQGR,DA,DIQGAUDD,"DIQGAUDR")
- +4 NEW DFF,DIQGSI,DIQGDD,DIQGWPB,DIQGWPO
- SET DIQGDD=DIQGPARM["D"
- SET DIQGWPB=DIQGPARM["B"
- +5 SET DIQGWPO=1
- +6 NEW DIQGEY
- SET DIQGEY("FILE")=$GET(DIQGR)
- SET DIQGEY("RECORD")=$GET(DA)
- SET DIQGEY("FIELD")=$GET(DR)
- +7 IF '$DATA(DIQGR)
- NEW X
- SET X(1)="FILE"
- QUIT $$F(.X,1)
- +8 IF 'DIQGR
- IF 'DIQGIPAR
- NEW X
- SET X(1)="FILE"
- QUIT $$F(.X,12)
- DA if $GET(DA)[","
- DO IEN(DA,.DA)
- +1 IF $GET(DR)=""
- NEW X
- SET X(1)="FIELD"
- QUIT $$F(.X,10)
- +2 IF 'DIQGIPAR
- IF 'DIQGDD
- if $$N9^DIQGU(DIQGR,.DA)
- QUIT $$F(.DIQGEY,16)
- IF '$DATA(^DD(DIQGR))
- NEW X
- SET X(1)="FILE"
- QUIT $$F(.X,18)
- +3 SET DIQGETA=$GET(DIQGETA)
- IF DIQGETA["("&(DIQGETA'[")")
- NEW X
- SET X(1)="TARGET ARRAY"
- QUIT $$F(.X,14)
- +4 IF DIQGR
- SET DFF=DIQGR
- SET DIQGR=$SELECT(DIQGDD:$$DDROOT(DIQGR),1:$$ROOT^DIQGU(DIQGR,.DA))
- IF DIQGR=""
- NEW X
- SET X(1)="FILE and/or IEN"
- QUIT $$F(.X,4)
- DFF ;does the file exist?
- SET DIQGSI=$$CREF(DIQGR)
- IF '$DATA(DFF)
- SET DFF=+$PIECE($GET(@DIQGSI@(0)),U,2)
- IF 'DFF
- IF DIQGPARM'["D"
- NEW X
- SET X("FILE")=DIQGSI
- QUIT $$F(.X,6)
- +1 ;Entry may have existed audited in the past
- IF '$DATA(@DIQGSI@(DA))
- IF 'DIQGIPAR
- IF DIQGPARM'["A"
- QUIT $$F(.DIQGEY,19)
- +2 IF '$GET(DT)
- NEW DT
- SET DT=$$DT^DIQGU($HOROLOG)
- +3 NEW DIQGPI,DIQGZN
- SET DIQGPI=DIQGPARM["I"
- SET DIQGZN=DIQGPARM["Z"
- +4 NEW %,%H,%T,I,J,N,X
- D0 SET X=0
- SET N="D0"
- FOR
- SET X=$ORDER(DA(X))
- if X'>0
- QUIT
- SET I=X
- SET N=N_",D"_X
- +1 NEW @N
- +2 SET @("D"_+$GET(I)_"=DA")
- IF $GET(I)
- FOR J=I-1:-1:0
- SET @("D"_J_"=DA(I-J)")
- +3 NEW C,P,Y,DIQGDN,DIQGD4,DIQGDRN
- +4 SET (X,Y)=""
- SET DIQGDRN=DR
- DD ;name of ^DD
- SET DIQGDN="^DD("_$SELECT(DIQGPARM["D":0,1:DFF)_")"
- FIELD IF DR'?.N
- IF $DATA(@DIQGDN@("B",DR))
- SET DIQGDRN=$ORDER(^(DR,""))
- IF $ORDER(^(DIQGDRN))
- NEW X
- SET X("FILE")=DIQGDN
- SET X(1)=DR
- QUIT $$F(.X,15)
- +1 IF DIQGDD
- IF DIQGDRN'>0
- Begin DoDot:1
- +2 SET DIQGDRN=$$DDN^DIQGU0(DR)
- if $EXTRACT(DIQGDRN,1,6)="$$$ NO"
- QUIT
- +3 SET DIQGDN="^DD("_$PIECE(DIQGDRN,"^")_")"
- SET DIQGDRN=$PIECE(DIQGDRN,"^",2)
- End DoDot:1
- IF $EXTRACT(DIQGDRN,1,6)="$$$ NO"
- NEW X
- SET X(1)="ATTRIBUTE"
- QUIT $$F(.X,17)
- +4 IF DIQGDRN>0
- IF $DATA(@DIQGDN@(DIQGDRN,0))
- SET DIQGD4=$PIECE(^(0),"^",4)
- SET C=$PIECE(^(0),"^",2)
- SET P=$PIECE(DIQGD4,";")
- if $PIECE(DIQGD4,";",2)'>0
- GOTO DIQ
- SET Y=$PIECE($GET(@DIQGSI@(DA,P)),"^",$PIECE(DIQGD4,";",2))
- GOTO DIQ
- TRYCOMP ;DON'T ALLOW COMPUTED EXPRESSIONS EXCEPT FROM $$GET1^DIQ
- NEW X,DIQGS
- IF 'DIQGIPAR
- DO EXPR(DFF,DR)
- +1 IF $DATA(X)
- SET C=Y
- if C["m"
- GOTO C
- DO CMPAUD(DR,$GET(X("USED")))
- IF $DATA(X)
- XECUTE X
- QUIT X
- GIVEUP QUIT $$F(.DIQGEY,7)
- +1 ;
- DIQ ;AT THIS POINT, 'Y' IS THE VALUE OF THE ATTRIBUTE WE WANT
- IF DIQGDRN=.001
- SET Y=DA
- +1 if C
- GOTO BMW
- if C'["C"
- GOTO REAL
- C ;S X(1)="MULTILINE COMPUTED" Q $$F(.X,3)
- IF C["m"
- NEW X
- Begin DoDot:1
- +1 NEW D,DICMX
- +2 IF DIQGETA=""
- SET X(1)="TARGET ARRAY for the MULTI-LINE COMPUTED FIELD"
- DO BLD^DIALOG(202,.X)
- KILL X
- QUIT
- +3 ;"Z" PARAMETER SAYS TO PUT ZERO NODES IN MULTIPLE
- SET DICMX="S @DIQGETA@(D"_$SELECT(DIQGZN:",0",1:"")_")=X"
- +4 ;XECUTE COMPUTED MULTIPLE
- XECUTE $PIECE(@DIQGDN@(DIQGDRN,0),U,5,999)
- End DoDot:1
- if '$DATA(X)
- GOTO FE
- if DIQGWPO
- QUIT $NAME(@DIQGETA)
- QUIT ""
- +5 IF DIQGDN="^DD(1.005)"
- IF DIQGDRN=1
- SET X=@DIQGSI@(DA,0)
- +6 NEW DCC,DIQGH,X,DFF
- SET DIQGH=$GET(DIERR)
- SET DCC=DIQGR
- SET DFF=+$PIECE(DCC,"(",2)
- +7 IF $DATA(@DIQGDN@(DIQGDRN,9.01))
- IF $DATA(^(9.1))
- DO CMPAUD(^(9.1),^(9.01))
- IF $DATA(X)
- XECUTE X
- IF 1
- +8 ;HELLEVI
- IF '$TEST
- SET X=""
- XECUTE $PIECE(@DIQGDN@(DIQGDRN,0),"^",5,999)
- +9 if DIQGH'=$GET(DIERR)
- Begin DoDot:1
- +10 NEW X
- +11 DO BLD^DIALOG(120,"FIELD")
- End DoDot:1
- +12 IF $GET(X)=""!DIQGPI
- QUIT $GET(X)
- CP IF C["p"
- IF X
- SET C=+$PIECE(C,"p",2)
- IF C
- IF $DATA(^DIC(C,0,"GL"))
- IF $DATA(@(^("GL")_"0)"))
- IF $DATA(^(X,0))
- QUIT $$EXTERNAL^DIDU(C,.01,"",$PIECE(^(0),U))
- +1 ;***
- QUIT $SELECT(C["D":$$DATE^DIUTL(X),1:X)
- +2 ;
- REAL ;SPACES ARE NULL
- IF $EXTRACT($PIECE(DIQGD4,";",2))="E"
- SET Y=$EXTRACT($GET(@DIQGSI@(DA,P)),$EXTRACT($PIECE($PIECE(DIQGD4,";",2),","),2,99),$PIECE($PIECE(DIQGD4,";",2),",",2))
- if Y?." "
- SET Y=""
- AUDIT ;Is there an AUDIT TRAIL for the field?
- IF $GET(DIQGAUDD)
- Begin DoDot:1
- +1 ;If entry was created after DIQGAUDD, we know there were no FIELD values!
- IF $GET(DIQGAUDR(DFF,$$DA^DIQGQ(.DA)))
- SET Y=""
- QUIT
- +2 SET P=$GET(DIQGAUDR(DFF,$$DA^DIQGQ(.DA),DIQGDRN))
- +3 IF P
- SET Y=$$DIA^DIAUTL(DIQGAUDD,DIQGAUDR,P)
- +4 if C'["P"!'Y
- QUIT
- NEW F
- SET F=+$PIECE(C,"P",2)
- if F=DIQGEY("FILE")&(Y=DA)
- QUIT
- +5 ;Recurse to get old POINTER value (as long as recursion isn't infinite!)
- SET Y=$$GET1^DIQ(F,Y_",",.01,"A"_DIQGAUDD)
- SET C=$TRANSLATE(C,"PO")
- End DoDot:1
- OUT ;"ALLOW" bad data
- IF 'DIQGPI&(C["O"!(C["S")!(C["P")!(C["V")!(C["D")!(C["t"))&($DATA(@DIQGDN@(DIQGDRN,0)))
- SET C=$PIECE(^(0),"^",2)
- QUIT $$EXTERNAL^DIDU(+$PIECE(DIQGDN,"(",2),DIQGDRN,"A",Y)
- +1 QUIT $GET(Y)
- +2 ;
- BMW ;PUT WORD-PROCESSING FIELD INTO @DIQGETA
- +1 IF C
- IF $PIECE(^DD(+C,.01,0),"^",2)["W"
- if DIQGWPB
- QUIT "$CREF$"_DIQGR_DA_","_$$Q^DIQGU(P)_")"
- Begin DoDot:1
- +2 IF DIQGETA']""
- KILL X
- SET X(1)="TARGET ARRAY"
- DO BLD^DIALOG(202,.X)
- SET X=""
- QUIT
- +3 SET X=DIQGR_DA_","_$$Q^DIQGU(P)_")"
- +4 IF '$ORDER(@X@(0))
- SET X=""
- QUIT
- +5 IF DIQGZN
- MERGE @DIQGETA=@X
- KILL @DIQGETA@(0)
- QUIT
- +6 SET Y=0
- FOR
- SET Y=$ORDER(@X@(Y))
- if Y'>0
- QUIT
- IF $DATA(^(Y,0))
- SET @DIQGETA@(Y)=^(0)
- +7 QUIT
- End DoDot:1
- if X=""
- GOTO FE
- if DIQGWPO
- QUIT $NAME(@DIQGETA)
- if DIQGIPAR
- QUIT "$WP$"
- QUIT ""
- +8 IF C
- IF $PIECE(^DD(+C,.01,0),"^",2)["M"
- QUIT $$F(.DIQGEY,11)
- +9 IF DIQGPI!(DIQGDD)
- QUIT $GET(Y)
- +10 QUIT $$F(.DIQGEY,8)
- CREF(X) NEW L,X1,X2,X3
- SET X1=$PIECE(X,"(")
- SET X2=$PIECE(X,"(",2,99)
- SET L=$LENGTH(X2)
- SET X3=$TRANSLATE($EXTRACT(X2,L),",)")
- SET X2=$EXTRACT(X2,1,(L-1))_X3
- QUIT X1_$SELECT(X2]"":"("_X2_")",1:"")
- WP(DIQGSA,DIQGTA,DIQGZN,DIQGP) NEW DIQG
- SET DIQG=0
- FOR
- SET DIQG=$ORDER(@DIQGSA@(DIQG))
- if DIQG'>0
- QUIT
- IF $DATA(^(DIQG,0))
- SET @$SELECT(DIQGZN:"@DIQGTA@(DIQG,0)",1:"@DIQGTA@(DIQG)")=^(0)
- +1 if DIQGP
- QUIT "$WP$"
- QUIT ""
- DY(Y) ;***
- QUIT $$DATE^DIUTL(Y)
- IEN(IEN,DA) SET DA=$PIECE(IEN,",")
- NEW I
- FOR I=2:1
- if $PIECE(IEN,",",I)=""
- QUIT
- SET DA(I-1)=$PIECE(IEN,",",I)
- +1 QUIT
- DDROOT(X) if '$DATA(^DD(X))
- QUIT ""
- QUIT "^DD("_X_","
- +1 ;
- CMPAUD(DEXPR,DIQGS) ;DEXPR is Expression, DIQGS is string of Fields used
- +1 if '$GET(DIQGAUDD)
- QUIT
- +2 NEW I,F,FD,A
- +3 FOR I=1:1
- SET F=$PIECE(DIQGS,";",I)
- if F=""
- QUIT
- Begin DoDot:1
- +4 SET A=$GET(DIQGAUDR(+F,$$DA^DIQGQ(.DA),$PIECE(F,U,2)))
- +5 IF A
- SET DIQGS(1,+F,$PIECE(F,U,2))=""""_$$CONVQQ^DILIBF($$DIA^DIAUTL(DIQGAUDD,+F,A))_""""
- End DoDot:1
- +6 ;'TODAY' is the old date!
- SET DIQGS("TODAY")=DIQGAUDD\1
- SET DIQGS("TODAY","DATE")=1
- SET DIQGS("NOW")=DIQGAUDD
- SET DIQGS("NOW","DATE")=1
- +7 ;now we call DICOMP with old (audit) values plugged in to the field's Computed Expression --
- +8 DO EXPR(DIQGAUDR,DEXPR)
- +9 QUIT
- EXPR(DIFILE,DIEXPR) IF DIQGPI
- KILL X
- if $TRANSLATE(DIEXPR," 1234567890.?")=""
- QUIT
- SET DIEXPR="INTERNAL("_DIEXPR_")"
- +1 DO EXPR^DICOMP(DIFILE,"",DIEXPR,.DIQGS)
- +2 IF 'DIQGPI
- IF $GET(Y)["D"
- IF Y'["m"
- IF $DATA(X)#2
- SET X=X_" S X=$$DATE^DIUTL(X)"
- +3 QUIT
- +4 ;
- F(DIQGEY,X) DO BLD^DIALOG($PIECE($TEXT(TXT+X),";",4),.DIQGEY)
- FE IF $GET(DIQGERRA)]""
- DO CALLOUT^DIEFU(DIQGERRA)
- +1 QUIT ""
- TXT ;;
- +1 ;;file root/ref invalid;202;1
- +2 ;;record invalid;202;2
- +3 ;;multiline computed;520;3
- +4 ;;file ref invalid;202;4
- +5 ;;field name/number invalid;202;5
- +6 ;;DD ref for file/field invalid;401;6
- +7 ;;unable to find field name;200;7
- +8 ;;unable to identify type of data in DD;510;8
- +9 ;;unable to resolve extended ref;501;9
- +10 ;;field ref missing;202;10
- +11 ;;multiple field - invalid parameters;309;11
- +12 ;;file number not passed or invalid;202;12
- +13 ;;;;13
- +14 ;;invalid target array;202;14
- +15 ;;ambiguous field name;505;15
- +16 ;;record unavailable;602;16
- +17 ;;invalid attribute;202;17
- +18 ;;file not found;202;18
- +19 ;;record entry does not exist;601;19
- +20 ;;;;20