XDRCNT ;SF-IRMFO/OHPRD/LAB - Count/Tally records by status/merged status; [ 08/13/92 09:50 AM ] ;8/28/08 17:55
;;7.3;TOOLKIT;**23,113**;Apr 25, 1995;Build 5
;;Per VHA Directive 2004-038, this routine should not be modified.
;;
START ;
D EN^XDRVCHEK
D INFORM
D INIT
D GETFILE
G:XDRQFLG EOJ
D ZIS
G:XDRQFLG EOJ
D PROCESS
D EOJ
Q
EOJ ;Eoj cleanup
K XDRQFLG,XDRD,XDRFL,XDRCNT
S:$D(ZTQUEUED) ZTREQ="@"
K ZTSK,POP,I,S
W:$D(IOF) @IOF
D ^%ZISC
Q
INIT ;initialize variables
S XDRQFLG=0,XDRCNT("PG")=0
S X=$G(^DD(15,.03,0)) I X="" W !!,$C(7),"Dictionary error!! Notify a programmer!" S XDRQFLG=1 Q
S X=$P(X,U,3)
F I=1:1 S S=$P(X,";",I) Q:S="" S XDRCNT("STATUS",$P(S,":",1),"CNT")=0,XDRCNT("STATUS",$P(S,":",1),"NAME")=$P(S,":",2)
I '$D(XDRCNT("STATUS")) S XDRQFLG=1 W !!,"Dictionary error!! Notify a programmer!" Q
S X=$G(^DD(15,.05,0)) I X="" W !!,$C(7),"Dictionary error!! Notify a programmer!" S XDRQFLG=1 Q
S X=$P(X,U,3)
F I=1:1 S S=$P(X,";",I) Q:S="" S XDRCNT("MERGE STATUS",$P(S,":",1),"CNT")=0,XDRCNT("MERGE STATUS",$P(S,":",1),"NAME")=$P(S,":",2)
I '$D(XDRCNT("MERGE STATUS")) S XDRQFLG=1 W !!,"Dictionary error!! Notify a programmer!" Q
S XDRCNT("TOTAL RECS")=0
Q
;
GETFILE ;get file to tally records fo
K XDRFL
; XT*7.3*113 input variable XDRNOPT to FILE^XDRDQUE-if UNDEF, allows PATIENT file to be selected
N XDRNOPT
S DIC("A")="Tally duplicate entries for which file? " D FILE^XDRDQUE
Q:XDRQFLG
S XDRCNT("GBL")=^DIC(XDRFL,0,"GL"),XDRCNT("GBL")=$P(XDRCNT("GBL"),U,2)
Q
ZIS W !! K ZTSK,ZTQUEUED,IOP S %ZIS="PQM" D ^%ZIS
I POP S XDRQFLG=1 Q
I $D(IO("Q")) D TSKMN
Q
TSKMN ;
S ZTIO=$S($D(ION):ION,1:IO) I $D(IOST)#2,IOST]"" S ZTIO=ZTIO_";"_IOST
I $D(IO("DOC")),IO("DOC")]"" S ZTIO=ZTIO_";"_IO("DOC")
I $D(IOM)#2,IOM S ZTIO=ZTIO_";"_IOM I $D(IOSL)#2,IOSL S ZTIO=ZTIO_";"_IOSL
K ZTSAVE S ZTSAVE("*")=""
S ZTRTN="PROCESS^XDRCNT",ZTDTH="",ZTDESC="TALLY DUPLICATE RECORD STATUS" D ^%ZTLOAD S XDRQFLG=1
Q
PROCESS ;
NEW X,D,S
;S X=0_";"_XDRCNT("GBL") F S X=$O(^VA(15,"B",X)) Q:X=""!($P(X,";",2)'=XDRCNT("GBL")) D
S X=0_";"_XDRCNT("GBL") F S X=$O(^VA(15,"B",X)) Q:X="" I $P(X,";",2)=XDRCNT("GBL") D
. S D=0 F S D=$O(^VA(15,"B",X,D)) Q:D'=+D D
. . Q:^VA(15,"B",X,D)=1
. . S XDRCNT("TOTAL RECS")=XDRCNT("TOTAL RECS")+1
. . S S=$P(^VA(15,D,0),U,3)
. . I S=""
. . E S XDRCNT("STATUS",S,"CNT")=$G(XDRCNT("STATUS",S,"CNT"))+1
. . I S="V" D
. . . S S=+$P(^VA(15,D,0),U,5)
. . . S XDRCNT("MERGE STATUS",S,"CNT")=XDRCNT("MERGE STATUS",S,"CNT")+1
. . Q
.Q
PRINT ;print report
U IO
D HEADER
W !!,"Total Number of Duplicate Records for File ",$E(XDRD(0,0),1,18),": ",?65,$J(XDRCNT("TOTAL RECS"),6),!
W !?5,"STATUS field:" S X=0 F S X=$O(XDRCNT("STATUS",X)) Q:X="" D
.I $Y>(IOSL-5) D HEADER Q:$D(XDRCNT("QUIT")) W !
.W ?26,$E(XDRCNT("STATUS",X,"NAME"),1,34),?65,$J(XDRCNT("STATUS",X,"CNT"),6),!
W !?5,"MERGE STATUS field:" S X="" F S X=$O(XDRCNT("MERGE STATUS",X)) Q:X="" D
.I $Y>(IOSL-5) D HEADER Q:$D(XDRCNT("QUIT")) W !
.W ?26,$E(XDRCNT("MERGE STATUS",X,"NAME"),1,34),?65,$J(XDRCNT("MERGE STATUS",X,"CNT"),6),!
.Q
I $E(IOST)="C" W !!,"End of Report. Press return to exit" R X:DTIME
Q
N DIR,X,Y
I 'XDRCNT("PG") G HEADER1
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S XDRCNT("QUIT")="" Q
W:$D(IOF) @IOF S XDRCNT("PG")=XDRCNT("PG")+1
W !?3,$P(^DIC(4,DUZ(2),0),U) S Y=DT D DD^%DT W ?50,Y,?70,"Page ",XDRCNT("PG"),?78,!
W !?12,"TALLY OF DUPLICATE RECORDS' STATUS/MERGE STATUS FIELDS"
S XDRCNT("LENG")=7+$L(XDRD(0,0))
W !?((80-XDRCNT("LENG"))/2),"FILE: ",XDRD(0,0),?78,!
W !,$TR($J("",80)," ","-")
Q
INFORM ;inform user
W !!,"This report will tally the Status and Merge Status fields for all",!,"entries in the Duplicate record file for the file that you select.",!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXDRCNT 3930 printed Apr 09, 2024@21:41:11 Page 2
XDRCNT ;SF-IRMFO/OHPRD/LAB - Count/Tally records by status/merged status; [ 08/13/92 09:50 AM ] ;8/28/08 17:55
+1 ;;7.3;TOOLKIT;**23,113**;Apr 25, 1995;Build 5
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;;
START ;
+1 DO EN^XDRVCHEK
+2 DO INFORM
+3 DO INIT
+4 DO GETFILE
+5 if XDRQFLG
GOTO EOJ
+6 DO ZIS
+7 if XDRQFLG
GOTO EOJ
+8 DO PROCESS
+9 DO EOJ
+10 QUIT
EOJ ;Eoj cleanup
+1 KILL XDRQFLG,XDRD,XDRFL,XDRCNT
+2 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 KILL ZTSK,POP,I,S
+4 if $DATA(IOF)
WRITE @IOF
+5 DO ^%ZISC
+6 QUIT
INIT ;initialize variables
+1 SET XDRQFLG=0
SET XDRCNT("PG")=0
+2 SET X=$GET(^DD(15,.03,0))
IF X=""
WRITE !!,$CHAR(7),"Dictionary error!! Notify a programmer!"
SET XDRQFLG=1
QUIT
+3 SET X=$PIECE(X,U,3)
+4 FOR I=1:1
SET S=$PIECE(X,";",I)
if S=""
QUIT
SET XDRCNT("STATUS",$PIECE(S,":",1),"CNT")=0
SET XDRCNT("STATUS",$PIECE(S,":",1),"NAME")=$PIECE(S,":",2)
+5 IF '$DATA(XDRCNT("STATUS"))
SET XDRQFLG=1
WRITE !!,"Dictionary error!! Notify a programmer!"
QUIT
+6 SET X=$GET(^DD(15,.05,0))
IF X=""
WRITE !!,$CHAR(7),"Dictionary error!! Notify a programmer!"
SET XDRQFLG=1
QUIT
+7 SET X=$PIECE(X,U,3)
+8 FOR I=1:1
SET S=$PIECE(X,";",I)
if S=""
QUIT
SET XDRCNT("MERGE STATUS",$PIECE(S,":",1),"CNT")=0
SET XDRCNT("MERGE STATUS",$PIECE(S,":",1),"NAME")=$PIECE(S,":",2)
+9 IF '$DATA(XDRCNT("MERGE STATUS"))
SET XDRQFLG=1
WRITE !!,"Dictionary error!! Notify a programmer!"
QUIT
+10 SET XDRCNT("TOTAL RECS")=0
+11 QUIT
+12 ;
GETFILE ;get file to tally records fo
+1 KILL XDRFL
+2 ; XT*7.3*113 input variable XDRNOPT to FILE^XDRDQUE-if UNDEF, allows PATIENT file to be selected
+3 NEW XDRNOPT
+4 SET DIC("A")="Tally duplicate entries for which file? "
DO FILE^XDRDQUE
+5 if XDRQFLG
QUIT
+6 SET XDRCNT("GBL")=^DIC(XDRFL,0,"GL")
SET XDRCNT("GBL")=$PIECE(XDRCNT("GBL"),U,2)
+7 QUIT
ZIS WRITE !!
KILL ZTSK,ZTQUEUED,IOP
SET %ZIS="PQM"
DO ^%ZIS
+1 IF POP
SET XDRQFLG=1
QUIT
+2 IF $DATA(IO("Q"))
DO TSKMN
+3 QUIT
TSKMN ;
+1 SET ZTIO=$SELECT($DATA(ION):ION,1:IO)
IF $DATA(IOST)#2
IF IOST]""
SET ZTIO=ZTIO_";"_IOST
+2 IF $DATA(IO("DOC"))
IF IO("DOC")]""
SET ZTIO=ZTIO_";"_IO("DOC")
+3 IF $DATA(IOM)#2
IF IOM
SET ZTIO=ZTIO_";"_IOM
IF $DATA(IOSL)#2
IF IOSL
SET ZTIO=ZTIO_";"_IOSL
+4 KILL ZTSAVE
SET ZTSAVE("*")=""
+5 SET ZTRTN="PROCESS^XDRCNT"
SET ZTDTH=""
SET ZTDESC="TALLY DUPLICATE RECORD STATUS"
DO ^%ZTLOAD
SET XDRQFLG=1
+6 QUIT
PROCESS ;
+1 NEW X,D,S
+2 ;S X=0_";"_XDRCNT("GBL") F S X=$O(^VA(15,"B",X)) Q:X=""!($P(X,";",2)'=XDRCNT("GBL")) D
+3 SET X=0_";"_XDRCNT("GBL")
FOR
SET X=$ORDER(^VA(15,"B",X))
if X=""
QUIT
IF $PIECE(X,";",2)=XDRCNT("GBL")
Begin DoDot:1
+4 SET D=0
FOR
SET D=$ORDER(^VA(15,"B",X,D))
if D'=+D
QUIT
Begin DoDot:2
+5 if ^VA(15,"B",X,D)=1
QUIT
+6 SET XDRCNT("TOTAL RECS")=XDRCNT("TOTAL RECS")+1
+7 SET S=$PIECE(^VA(15,D,0),U,3)
+8 IF S=""
+9 IF '$TEST
SET XDRCNT("STATUS",S,"CNT")=$GET(XDRCNT("STATUS",S,"CNT"))+1
+10 IF S="V"
Begin DoDot:3
+11 SET S=+$PIECE(^VA(15,D,0),U,5)
+12 SET XDRCNT("MERGE STATUS",S,"CNT")=XDRCNT("MERGE STATUS",S,"CNT")+1
End DoDot:3
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
PRINT ;print report
+1 USE IO
+2 DO HEADER
+3 WRITE !!,"Total Number of Duplicate Records for File ",$EXTRACT(XDRD(0,0),1,18),": ",?65,$JUSTIFY(XDRCNT("TOTAL RECS"),6),!
+4 WRITE !?5,"STATUS field:"
SET X=0
FOR
SET X=$ORDER(XDRCNT("STATUS",X))
if X=""
QUIT
Begin DoDot:1
+5 IF $Y>(IOSL-5)
DO HEADER
if $DATA(XDRCNT("QUIT"))
QUIT
WRITE !
+6 WRITE ?26,$EXTRACT(XDRCNT("STATUS",X,"NAME"),1,34),?65,$JUSTIFY(XDRCNT("STATUS",X,"CNT"),6),!
End DoDot:1
+7 WRITE !?5,"MERGE STATUS field:"
SET X=""
FOR
SET X=$ORDER(XDRCNT("MERGE STATUS",X))
if X=""
QUIT
Begin DoDot:1
+8 IF $Y>(IOSL-5)
DO HEADER
if $DATA(XDRCNT("QUIT"))
QUIT
WRITE !
+9 WRITE ?26,$EXTRACT(XDRCNT("MERGE STATUS",X,"NAME"),1,34),?65,$JUSTIFY(XDRCNT("MERGE STATUS",X,"CNT"),6),!
+10 QUIT
End DoDot:1
+11 IF $EXTRACT(IOST)="C"
WRITE !!,"End of Report. Press return to exit"
READ X:DTIME
+12 QUIT
+1 NEW DIR,X,Y
+2 IF 'XDRCNT("PG")
GOTO HEADER1
+3 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET XDRCNT("QUIT")=""
QUIT
+1 if $DATA(IOF)
WRITE @IOF
SET XDRCNT("PG")=XDRCNT("PG")+1
+2 WRITE !?3,$PIECE(^DIC(4,DUZ(2),0),U)
SET Y=DT
DO DD^%DT
WRITE ?50,Y,?70,"Page ",XDRCNT("PG"),?78,!
+3 WRITE !?12,"TALLY OF DUPLICATE RECORDS' STATUS/MERGE STATUS FIELDS"
+4 SET XDRCNT("LENG")=7+$LENGTH(XDRD(0,0))
+5 WRITE !?((80-XDRCNT("LENG"))/2),"FILE: ",XDRD(0,0),?78,!
+6 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+7 QUIT
INFORM ;inform user
+1 WRITE !!,"This report will tally the Status and Merge Status fields for all",!,"entries in the Duplicate record file for the file that you select.",!
+2 QUIT
