DITCP0 ;GFT/MSC - COMPARE ACROSS UCIs OR COMPARE TWO ENTRIES ;16MAR2016
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;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.
;
UCI ;Compare across UCI's FILEMAN OPTION 9, SUBOPTION 3
N DITCPI,DIC,DIR,DITCPUCI,DIRUT,DIB,DITCPT
S Y=$$WUCI Q:Y="" D DT^DICRW,L^DICRW1 Q:'$D(DIC)
S DITCPI=+Y,DIR(0)="F^1:90",DIR("A")="Compare to what UCI",DIR("B")=$G(^DOPT("DITCPUCI",DUZ))
I $G(^DD("OS"))=18 S DIR("?")="^D UCIQ^DITCP0"
D ^DIR
D:'$D(DISYS) OS^DII
Q:U[X S Y="" X:X'["," $G(^DD("OS",DISYS,"UCICHECK")) I 0[Y W !!,X," IS NOT A VALID UCI!" Q
S ^DOPT("DITCPUCI",DUZ)=X,DITCPUCI=X
K DIR S DIR(0)="S^1:DATA DICTIONARY ONLY;2:FILE ENTRIES ONLY;3:DATA DICTIONARY AND FILE ENTRIES",DIR("B")=3 D ^DIR
Q:U[X S DIB=Y
D START Q:IO=""
S DIR=DITCPI
DD K DITCPT
I DIB#2 D EN^DITCP("^DD("_DITCPI_")","^["""_DITCPUCI_"""]DD("_DITCPI_")",0,1,.DITCPT) F X=0:0 S X=$O(^DD(DITCPI,"SB",X)) Q:'X S DITCPI(X)=""
I '$D(DIRUT) S DITCPI=$O(DITCPI(0)) I DITCPI K DITCPI(DITCPI) G DD
FILES S X=$G(DITCPT) K DITCPT S DITCPT=X
I '$D(DIRUT),DIB>1,$D(^DIC(DIR)) S X=$$CREF^DILF(^DIC(DIR,0,"GL")) D EN^DITCP(X,"^["""_DITCPUCI_"""]"_$P(X,U,2,9),DIR,1,.DITCPT)
I '$D(DIRUT) S DIR=$O(^DIC(DIR)) I DIR,DIR'>DIB(1) K DITCPI S DITCPI=DIR G DD
C G CLOSE^DIO4
;
;
UCIQ ;HELP
N L W !?4,"CHOOSE FROM:" D ;***CACHE-SPECIFIC FROM %NSP
.X "n gft,UCI f UCI=1:1:$zu(90,0) s gft=$zu(90,2,0,UCI) s:$l(gft) L(gft)=0"
S L="" F S L=$O(L(L)) Q:L="" W !?8,L
Q
;
;
ENTRIES ;Compare entries in a File
N D1,D2,DIRUT,DITCP
I $D(DIU) S DIC=DIU
E D R^DICRW Q:'$D(DIC)
S DIC(0)="AEQM" D ^DIC Q:Y<0 S DITCP=+Y,DIC("A")="Select a SECOND: ",DIC("S")="I Y-"_+Y D ^DIC K DIC("S"),DIC("A") Q:Y<0
S D1=DIC_DITCP_")",D2=DIC_+Y_")",DIDD=+$P(@(DIC_"0)"),U,2)
D START Q:IO=""
D EN^DITCP(D1,D2,DIDD,"2N")
G C
;
;
;
START ;
W !,"DISPLAY COMPARISON ON" K %ZIS D ^%ZIS K POP Q:IO="" U IO
D DT^DICRW S Y=DT D DD^%DT W !,Y I $D(^DD("SITE")) W ?14,^("SITE") S Y=$$WUCI
I $D(DITCPUCI) S %=$L(DITCPUCI) W ?$S(IOM\2>%:IOM\2,1:IOM-%),"UCI: "_DITCPUCI
W ! F %=1:1:IOM W "-"
Q
;
WUCI() ;
N Y I ^DD("OS")=19!(^DD("OS")=17) X "S Y=$ZGD" ;GTM GLOBAL DIRECTORY
E I $D(^%ZOSF("UCI"))#2 X ^("UCI")
I $D(Y) W !?2,"UCI: "_Y Q Y
Q ""
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDITCP0 2502 printed Apr 09, 2024@21:56:46 Page 2
DITCP0 ;GFT/MSC - COMPARE ACROSS UCIs OR COMPARE TWO ENTRIES ;16MAR2016
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+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 ;
UCI ;Compare across UCI's FILEMAN OPTION 9, SUBOPTION 3
+1 NEW DITCPI,DIC,DIR,DITCPUCI,DIRUT,DIB,DITCPT
+2 SET Y=$$WUCI
if Y=""
QUIT
DO DT^DICRW
DO L^DICRW1
if '$DATA(DIC)
QUIT
+3 SET DITCPI=+Y
SET DIR(0)="F^1:90"
SET DIR("A")="Compare to what UCI"
SET DIR("B")=$GET(^DOPT("DITCPUCI",DUZ))
+4 IF $GET(^DD("OS"))=18
SET DIR("?")="^D UCIQ^DITCP0"
+5 DO ^DIR
+6 if '$DATA(DISYS)
DO OS^DII
+7 if U[X
QUIT
SET Y=""
if X'[","
XECUTE $GET(^DD("OS",DISYS,"UCICHECK"))
IF 0[Y
WRITE !!,X," IS NOT A VALID UCI!"
QUIT
+8 SET ^DOPT("DITCPUCI",DUZ)=X
SET DITCPUCI=X
+9 KILL DIR
SET DIR(0)="S^1:DATA DICTIONARY ONLY;2:FILE ENTRIES ONLY;3:DATA DICTIONARY AND FILE ENTRIES"
SET DIR("B")=3
DO ^DIR
+10 if U[X
QUIT
SET DIB=Y
+11 DO START
if IO=""
QUIT
+12 SET DIR=DITCPI
DD KILL DITCPT
+1 IF DIB#2
DO EN^DITCP("^DD("_DITCPI_")","^["""_DITCPUCI_"""]DD("_DITCPI_")",0,1,.DITCPT)
FOR X=0:0
SET X=$ORDER(^DD(DITCPI,"SB",X))
if 'X
QUIT
SET DITCPI(X)=""
+2 IF '$DATA(DIRUT)
SET DITCPI=$ORDER(DITCPI(0))
IF DITCPI
KILL DITCPI(DITCPI)
GOTO DD
FILES SET X=$GET(DITCPT)
KILL DITCPT
SET DITCPT=X
+1 IF '$DATA(DIRUT)
IF DIB>1
IF $DATA(^DIC(DIR))
SET X=$$CREF^DILF(^DIC(DIR,0,"GL"))
DO EN^DITCP(X,"^["""_DITCPUCI_"""]"_$PIECE(X,U,2,9),DIR,1,.DITCPT)
+2 IF '$DATA(DIRUT)
SET DIR=$ORDER(^DIC(DIR))
IF DIR
IF DIR'>DIB(1)
KILL DITCPI
SET DITCPI=DIR
GOTO DD
C GOTO CLOSE^DIO4
+1 ;
+2 ;
UCIQ ;HELP
+1 ;***CACHE-SPECIFIC FROM %NSP
NEW L
WRITE !?4,"CHOOSE FROM:"
Begin DoDot:1
+2 XECUTE "n gft,UCI f UCI=1:1:$zu(90,0) s gft=$zu(90,2,0,UCI) s:$l(gft) L(gft)=0"
End DoDot:1
+3 SET L=""
FOR
SET L=$ORDER(L(L))
if L=""
QUIT
WRITE !?8,L
+4 QUIT
+5 ;
+6 ;
ENTRIES ;Compare entries in a File
+1 NEW D1,D2,DIRUT,DITCP
+2 IF $DATA(DIU)
SET DIC=DIU
+3 IF '$TEST
DO R^DICRW
if '$DATA(DIC)
QUIT
+4 SET DIC(0)="AEQM"
DO ^DIC
if Y<0
QUIT
SET DITCP=+Y
SET DIC("A")="Select a SECOND: "
SET DIC("S")="I Y-"_+Y
DO ^DIC
KILL DIC("S"),DIC("A")
if Y<0
QUIT
+5 SET D1=DIC_DITCP_")"
SET D2=DIC_+Y_")"
SET DIDD=+$PIECE(@(DIC_"0)"),U,2)
+6 DO START
if IO=""
QUIT
+7 DO EN^DITCP(D1,D2,DIDD,"2N")
+8 GOTO C
+9 ;
+10 ;
+11 ;
START ;
+1 WRITE !,"DISPLAY COMPARISON ON"
KILL %ZIS
DO ^%ZIS
KILL POP
if IO=""
QUIT
USE IO
+2 DO DT^DICRW
SET Y=DT
DO DD^%DT
WRITE !,Y
IF $DATA(^DD("SITE"))
WRITE ?14,^("SITE")
SET Y=$$WUCI
+3 IF $DATA(DITCPUCI)
SET %=$LENGTH(DITCPUCI)
WRITE ?$SELECT(IOM\2>%:IOM\2,1:IOM-%),"UCI: "_DITCPUCI
+4 WRITE !
FOR %=1:1:IOM
WRITE "-"
+5 QUIT
+6 ;
WUCI() ;
+1 ;GTM GLOBAL DIRECTORY
NEW Y
IF ^DD("OS")=19!(^DD("OS")=17)
XECUTE "S Y=$ZGD"
+2 IF '$TEST
IF $DATA(^%ZOSF("UCI"))#2
XECUTE ^("UCI")
+3 IF $DATA(Y)
WRITE !?2,"UCI: "_Y
QUIT Y
+4 QUIT ""
