- DPTDZALP ; IHS/TUCSON/JCM - alphabetical listing of va 15 for file 2 ;
- ;;1.0;PATIENT MERGE;;FEB 02, 1994
- ;;
- START ;
- W !!,"This report will contain an alphabetical listing of all of the patients in the",!,"Duplicate Record file.",!
- ZIS W !! K ZTSK,ZTQUEUED,IOP S %IS="PQM" D ^%ZIS
- I POP G XIT
- I $D(IO("Q")) G TSKMN
- DRIVER ; entry point for taskman
- K ^TMP("DPTDZALP",$J)
- PROC ;
- S DPTDZALP("X")=0 F S DPTDZALP("X")=$O(^VA(15,DPTDZALP("X"))) Q:DPTDZALP("X")'=+DPTDZALP("X") I $P($P(^VA(15,DPTDZALP("X"),0),";",2),"(",1)="DPT" D
- .S ^TMP("DPTDZALP",$J,$P(^DPT($P(^VA(15,DPTDZALP("X"),0),";"),0),U))=DPTDZALP("X")
- U IO
- S Y=DT X ^DD("DD") S DPTDZALP("DT")=Y
- PRN S DPTDZALP("PG")=0 D HEAD
- S DPTDZALP("X")=0 F S DPTDZALP("X")=$O(^TMP("DPTDZALP",$J,DPTDZALP("X"))) Q:DPTDZALP("X")=""!($D(DPTDZALP("QUIT"))) D
- .S DPTDZALP("Y")=^TMP("DPTDZALP",$J,DPTDZALP("X"))
- .I $Y>(IOSL-8) D HEAD Q:$D(DPTDZALP("QUIT"))
- .W !!,"RECORD1: ",DPTDZALP("X"),?40,"RECORD2: ",?50,$P(^DPT($P($P(^VA(15,DPTDZALP("Y"),0),"^",2),";"),0),U)
- .W !,"STATUS: " S Y=$P(^VA(15,DPTDZALP("Y"),0),U,3),C=$P(^DD(15,.03,0),U,2) D Y^DIQ W Y,?40,"MERGE DIRECTION: " S Y=$P(^VA(15,DPTDZALP("Y"),0),U,4),C=$P(^DD(15,.04,0),U,2) D Y^DIQ W Y
- .W !,"MERGE STATUS: " S Y=$P(^VA(15,DPTDZALP("Y"),0),U,5),C=$P(^DD(15,.05,0),U,2) D Y^DIQ W Y,?40,"DATE FOUND: " S Y=$P(^VA(15,DPTDZALP("Y"),0),U,4),C=$P(^DD(15,.06,0),U,2) D Y^DIQ W Y
- .W !,"DATE VERIFIED: " S Y=$P(^VA(15,DPTDZALP("Y"),0),U,7),C=$P(^DD(15,.07,0),U,2) D Y^DIQ W Y,?40,"DATE RESOLVED: " S Y=$P(^VA(15,DPTDZALP("Y"),0),U,8),C=$P(^DD(15,.08,0),U,2) D Y^DIQ W Y
- .W !,"WHO CREATED: " S Y=$P(^VA(15,DPTDZALP("Y"),0),U,9),C=$P(^DD(15,.09,0),U,2) D Y^DIQ W Y,?40,"WHO VERIFIED: " I $P(^VA(15,DPTDZALP("Y"),0),U,11)]"" S Y=$P(^VA(15,DPTDZALP("Y"),0),U,11),C=$P(^DD(15,.11,0),U,2) D Y^DIQ W Y
- .W !,"DC TOTAL POSSIBLE SCORE: " S Y=$P(^VA(15,DPTDZALP("Y"),0),U,15),C=$P(^DD(15,.15,0),U,2) D Y^DIQ W Y,?40,"DC POTENTIAL DUPE THRESHOLD %: " S Y=$P(^VA(15,DPTDZALP("Y"),0),U,17),C=$P(^DD(15,.17,0),U,2) D Y^DIQ W Y
- .W !,"DC DUPE MATCH SCORE : " S Y=$P(^VA(15,DPTDZALP("Y"),0),U,18),C=$P(^DD(15,.18,0),U,2) D Y^DIQ W Y,?40,"DC DUPE MATCH PERCENTILE: " S Y=$P(^VA(15,DPTDZALP("Y"),0),U,19),C=$P(^DD(15,.19,0),U,2) D Y^DIQ W Y
- K:$D(ZTSK) ^%ZTSK(ZTSK)
- D XIT
- Q
- XIT ;
- K DPTDZALP
- K X,Y,DIR,DUOUT,DIRUT,DTOUT
- Q
- ERR W $C(7),$C(7),!,"Must be a valid date and be Today or earlier. Time not allowed!" Q
- HEAD I 'DPTDZALP("PG") G HEAD1
- I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S DPTDZALP("QUIT")="" Q
- HEAD1 ;
- W:$D(IOF) @IOF S DPTDZALP("PG")=DPTDZALP("PG")+1
- W "*",?3,$P(^DIC(4,DUZ(2),0),U,1)," ",DPTDZALP("DT"),?70,"Page ",DPTDZALP("PG"),?78,"*",!
- W !?10,"ALPHABETICAL LISTING OF PATIENTS IN DUPLICATE RECORD FILE",!
- S X="",$P(X,"_",79)="" W X,!
- 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_$S($D(IO("DOC")):";"_IO("DOC"),1:"")
- I $D(IOM)#2,IOM S ZTIO=ZTIO_";"_IOM I $D(IOSL)#2,IOSL S ZTIO=ZTIO_";"_IOSL
- S ZTSAVE("*")=""
- S ZTRTN="DRIVER^DPTDZALP",ZTDTH="",ZTDESC="PAT MERGE ALPHA LIST" D ^%ZTLOAD D XIT Q
- ;
- ;
- DPTDZALP ; IHS/TUCSON/JCM - alphabetical listing of va 15 for file 2 ;
- +1 ;;1.0;PATIENT MERGE;;FEB 02, 1994
- +2 ;;
- START ;
- +1 WRITE !!,"This report will contain an alphabetical listing of all of the patients in the",!,"Duplicate Record file.",!
- ZIS WRITE !!
- KILL ZTSK,ZTQUEUED,IOP
- SET %IS="PQM"
- DO ^%ZIS
- +1 IF POP
- GOTO XIT
- +2 IF $DATA(IO("Q"))
- GOTO TSKMN
- DRIVER ; entry point for taskman
- +1 KILL ^TMP("DPTDZALP",$JOB)
- PROC ;
- +1 SET DPTDZALP("X")=0
- FOR
- SET DPTDZALP("X")=$ORDER(^VA(15,DPTDZALP("X")))
- IF DPTDZALP("X")'=+DPTDZALP("X")
- QUIT
- IF $PIECE($PIECE(^VA(15,DPTDZALP("X"),0),";",2),"(",1)="DPT"
- Begin DoDot:1
- +2 SET ^TMP("DPTDZALP",$JOB,$PIECE(^DPT($PIECE(^VA(15,DPTDZALP("X"),0),";"),0),U))=DPTDZALP("X")
- End DoDot:1
- +3 USE IO
- +4 SET Y=DT
- XECUTE ^DD("DD")
- SET DPTDZALP("DT")=Y
- PRN SET DPTDZALP("PG")=0
- DO HEAD
- +1 SET DPTDZALP("X")=0
- FOR
- SET DPTDZALP("X")=$ORDER(^TMP("DPTDZALP",$JOB,DPTDZALP("X")))
- IF DPTDZALP("X")=""!($DATA(DPTDZALP("QUIT")))
- QUIT
- Begin DoDot:1
- +2 SET DPTDZALP("Y")=^TMP("DPTDZALP",$JOB,DPTDZALP("X"))
- +3 IF $Y>(IOSL-8)
- DO HEAD
- IF $DATA(DPTDZALP("QUIT"))
- QUIT
- +4 WRITE !!,"RECORD1: ",DPTDZALP("X"),?40,"RECORD2: ",?50,$PIECE(^DPT($PIECE($PIECE(^VA(15,DPTDZALP("Y"),0),"^",2),";"),0),U)
- +5 WRITE !,"STATUS: "
- SET Y=$PIECE(^VA(15,DPTDZALP("Y"),0),U,3)
- SET C=$PIECE(^DD(15,.03,0),U,2)
- DO Y^DIQ
- WRITE Y,?40,"MERGE DIRECTION: "
- SET Y=$PIECE(^VA(15,DPTDZALP("Y"),0),U,4)
- SET C=$PIECE(^DD(15,.04,0),U,2)
- DO Y^DIQ
- WRITE Y
- +6 WRITE !,"MERGE STATUS: "
- SET Y=$PIECE(^VA(15,DPTDZALP("Y"),0),U,5)
- SET C=$PIECE(^DD(15,.05,0),U,2)
- DO Y^DIQ
- WRITE Y,?40,"DATE FOUND: "
- SET Y=$PIECE(^VA(15,DPTDZALP("Y"),0),U,4)
- SET C=$PIECE(^DD(15,.06,0),U,2)
- DO Y^DIQ
- WRITE Y
- +7 WRITE !,"DATE VERIFIED: "
- SET Y=$PIECE(^VA(15,DPTDZALP("Y"),0),U,7)
- SET C=$PIECE(^DD(15,.07,0),U,2)
- DO Y^DIQ
- WRITE Y,?40,"DATE RESOLVED: "
- SET Y=$PIECE(^VA(15,DPTDZALP("Y"),0),U,8)
- SET C=$PIECE(^DD(15,.08,0),U,2)
- DO Y^DIQ
- WRITE Y
- +8 WRITE !,"WHO CREATED: "
- SET Y=$PIECE(^VA(15,DPTDZALP("Y"),0),U,9)
- SET C=$PIECE(^DD(15,.09,0),U,2)
- DO Y^DIQ
- WRITE Y,?40,"WHO VERIFIED: "
- IF $PIECE(^VA(15,DPTDZALP("Y"),0),U,11)]""
- SET Y=$PIECE(^VA(15,DPTDZALP("Y"),0),U,11)
- SET C=$PIECE(^DD(15,.11,0),U,2)
- DO Y^DIQ
- WRITE Y
- +9 WRITE !,"DC TOTAL POSSIBLE SCORE: "
- SET Y=$PIECE(^VA(15,DPTDZALP("Y"),0),U,15)
- SET C=$PIECE(^DD(15,.15,0),U,2)
- DO Y^DIQ
- WRITE Y,?40,"DC POTENTIAL DUPE THRESHOLD %: "
- SET Y=$PIECE(^VA(15,DPTDZALP("Y"),0),U,17)
- SET C=$PIECE(^DD(15,.17,0),U,2)
- DO Y^DIQ
- WRITE Y
- +10 WRITE !,"DC DUPE MATCH SCORE : "
- SET Y=$PIECE(^VA(15,DPTDZALP("Y"),0),U,18)
- SET C=$PIECE(^DD(15,.18,0),U,2)
- DO Y^DIQ
- WRITE Y,?40,"DC DUPE MATCH PERCENTILE: "
- SET Y=$PIECE(^VA(15,DPTDZALP("Y"),0),U,19)
- SET C=$PIECE(^DD(15,.19,0),U,2)
- DO Y^DIQ
- WRITE Y
- End DoDot:1
- +11 IF $DATA(ZTSK)
- KILL ^%ZTSK(ZTSK)
- +12 DO XIT
- +13 QUIT
- XIT ;
- +1 KILL DPTDZALP
- +2 KILL X,Y,DIR,DUOUT,DIRUT,DTOUT
- +3 QUIT
- ERR WRITE $CHAR(7),$CHAR(7),!,"Must be a valid date and be Today or earlier. Time not allowed!"
- QUIT
- HEAD IF 'DPTDZALP("PG")
- GOTO HEAD1
- +1 IF $EXTRACT(IOST)="C"
- IF IO=IO(0)
- WRITE !
- SET DIR(0)="EO"
- DO ^DIR
- KILL DIR
- IF Y=0!(Y="^")!($DATA(DTOUT))
- SET DPTDZALP("QUIT")=""
- QUIT
- HEAD1 ;
- +1 IF $DATA(IOF)
- WRITE @IOF
- SET DPTDZALP("PG")=DPTDZALP("PG")+1
- +2 WRITE "*",?3,$PIECE(^DIC(4,DUZ(2),0),U,1)," ",DPTDZALP("DT"),?70,"Page ",DPTDZALP("PG"),?78,"*",!
- +3 WRITE !?10,"ALPHABETICAL LISTING OF PATIENTS IN DUPLICATE RECORD FILE",!
- +4 SET X=""
- SET $PIECE(X,"_",79)=""
- WRITE X,!
- +5 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_$SELECT($DATA(IO("DOC")):";"_IO("DOC"),1:"")
- +3 IF $DATA(IOM)#2
- IF IOM
- SET ZTIO=ZTIO_";"_IOM
- IF $DATA(IOSL)#2
- IF IOSL
- SET ZTIO=ZTIO_";"_IOSL
- +4 SET ZTSAVE("*")=""
- +5 SET ZTRTN="DRIVER^DPTDZALP"
- SET ZTDTH=""
- SET ZTDESC="PAT MERGE ALPHA LIST"
- DO ^%ZTLOAD
- DO XIT
- QUIT
- +6 ;
- +7 ;
