APCDRLR ; IHS/CMI/LAB - report of visits re-linked ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
;
START ;EP - called from option
D XIT
W:$D(IOF) @IOF
W !!,"This option will print a list of visits on which a V File (ancillary"
W !,"data item was 'moved' or 're-linked' from one visit to another during the"
W !,"nightly visit re-linker process or during the post data entry visit re-linking"
W !,"process.",!
W !,"You will be asked to enter the date range on which the nightly"
W !,"visit re-linker was run.",!
;
GETDATES ;
W !!,"Please enter the range of dates on which the 're-linking' occurred."
BD ;get beginning date
W ! S DIR(0)="D^:DT:EP",DIR("A")="Enter beginning Date" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) G XIT
S APCDBD=Y
ED ;get ending date
W ! S DIR(0)="D^"_APCDBD_":DT:EP",DIR("A")="Enter ending Date" S Y=APCDBD D DD^%DT D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) G BD
S APCDED=Y
S X1=APCDBD,X2=-1 D C^%DTC S APCDSD=X S Y=APCDBD D DD^%DT S APCDBDD=Y S Y=APCDED D DD^%DT S APCDEDD=Y
DEMO ;
D DEMOCHK^APCLUTL(.APCDDEMO)
I APCDDEMO=-1 G BD
ZIS ;
S DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen",DIR("A")="Do you wish to ",DIR("B")="P" K DA D ^DIR K DIR
I $D(DIRUT) G XIT
I $G(Y)="B" D BROWSE,XIT Q
W !! S XBRP="PRINT^APCDRLR",XBRC="PROC^APCDRLR",XBNS="APCD*",XBRX="XIT^APCDRLR"
D ^XBDBQUE
D XIT
Q
BROWSE ;
S XBRP="VIEWR^XBLM(""PRINT^APCDRLR"")"
S XBNS="APCD",XBRC="PROC^APCDRLR",XBRX="XIT^APCDRLR",XBIOP=0 D ^XBDBQUE
Q
;
PROC ;EP - called from xbdbque
;loop through all visits in date range and look for problem 8-8.9 or visit type of N
S APCDJOB=$J,APCDTOT=0,APCDBT=$H
D XTMP("APCDRLR","LIST FROM VISIT RELINKER")
S X1=APCDBD,X2=-1 D C^%DTC S APCDSD=X
S APCDODAT=APCDSD_".9999" F S APCDODAT=$O(^APCDKLOG("B",APCDODAT)) Q:APCDODAT=""!((APCDODAT\1)>APCDED) D
.S APCDR=0 F S APCDR=$O(^APCDKLOG("B",APCDODAT,APCDR)) Q:APCDR'=+APCDR D
..S F=$P(^APCDKLOG(APCDR,0),U,5) I F,$D(^AUPNVSIT(F,0)) Q:$$DEMO^APCLUTL($P(^AUPNVSIT(F,0),U,5),APCDDEMO)
..S ^XTMP("APCDRLR",APCDJOB,APCDBT,"VISITS",APCDODAT,APCDR)="",APCDTOT=APCDTOT+1
Q
PRINT ;EP - called from xbdbque
K APCDQ S APCDPG=0
I '$D(^XTMP("APCDRLR",APCDJOB,APCDBT,"VISITS")) D HEADER W !!,"There are no visits in the Visit Relinker Log for that time period.",! Q
D HEADER
S APCDD=0 F S APCDD=$O(^XTMP("APCDRLR",APCDJOB,APCDBT,"VISITS",APCDD)) Q:APCDD=""!($D(APCDQ)) D
.I $Y>(IOSL-5) D HEADER Q:$D(APCDQ)
.W !!,"Date of Visit Relinker: ",$$FMTE^XLFDT(APCDD)
.S APCDR=0 F S APCDR=$O(^XTMP("APCDRLR",APCDJOB,APCDBT,"VISITS",APCDD,APCDR)) Q:APCDR'=+APCDR!($D(APCDQ)) D
..I $Y>(IOSL-5) D HEADER Q:$D(APCDQ)
..S APCDN=^APCDKLOG(APCDR,0)
..S APCDTV=$P(APCDN,U,5)
..S DFN=$P($G(^AUPNVSIT(APCDTV,0)),U,5)
..W !!,$$HRN^AUPNPAT(DFN,DUZ(2)),?7,$E($P(^DPT(DFN,0),U),1,18),?25,$$FMTE^XLFDT($P(^AUPNVSIT(APCDTV,0),U),2)," (",APCDTV,")",?53,$$FMTE^XLFDT($P(^AUPNVSIT($P(APCDN,U,4),0),U),2)," (",$P(APCDN,U,4),")"
..W !?1,"Providers-To Visit: "
..S APCDX=0,APCDP="" F S APCDX=$O(^AUPNVPRV("AD",APCDTV,APCDX)) Q:APCDX'=+APCDX!($D(APCDQ)) D
...S APCDPRV=$P($G(^AUPNVPRV(APCDX,0)),U)
...I APCDPRV="" Q ;no provider?
...S:APCDP]"" APCDP=APCDP_"; "
...S APCDP=APCDP_$E($P(^VA(200,APCDPRV,0),U,1),1,12)
..W APCDP
..W !?1,"Data re-linked: "
..K APCDA S APCDX=0 F S APCDX=$O(^APCDKLOG(APCDR,11,APCDX)) Q:APCDX'=+APCDX D
...S F=$P(^APCDKLOG(APCDR,11,APCDX,0),U),B=$P(^DIC(F,0),U)
...S I=$P(^APCDKLOG(APCDR,11,APCDX,0),U,2)
...S P=$$VAL^XBDIQ1(F,I,1202) I P="" S P="UNKNOWN OR MISSING"
...S APCDA(B,P)=$G(APCDA(B,P))+1
..S APCDX="",APCDC=0 F S APCDX=$O(APCDA(APCDX)) Q:APCDX=""!($D(APCDQ)) D
...S APCDP="" F S APCDP=$O(APCDA(APCDX,APCDP)) Q:APCDP=""!($D(APCDQ)) D
....I $Y>(IOSL-4) D HEADER Q:$D(APCDQ)
....W:APCDC>0 ! W ?17,$E(APCDX,1,12),?31,"Ordering Prv: ",$E(APCDP,1,25),?75,"# ",APCDA(APCDX,APCDP)
....S APCDC=APCDC+1
W !!,"Total # of Visits: ",APCDTOT,!
K ^XTMP("APCDRLR",APCDJOB,APCDBT)
XIT ;
D EN^XBVK("APCD")
D KILL^AUPNPAT
Q
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
I 'APCDPG 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 APCDQ="" Q
W:$D(IOF) @IOF S APCDPG=APCDPG+1
W !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
W !?(80-$L($P(^DIC(4,DUZ(2),0),U))/2),$P(^DIC(4,DUZ(2),0),U),?($S(80=132:120,1:72)),"Page ",APCDPG,!
S APCDTEXT="Visits for which an Ancillary Data Item was 're-linked' to another visit"
W !?(80-$L(APCDTEXT)/2),APCDTEXT,!
S APCDTEXT="Relinking Dates: "_APCDBDD_" and "_APCDEDD
W ?(80-$L(APCDTEXT)/2),APCDTEXT,!
W $TR($J(" ",80)," ","-")
W !,?25,"TO VISIT",?53,"FROM VISIT"
W !,"HRN",?7,"PATIENT",?25,"DATE/TIME (IEN)",?53,"DATE/TIME (IEN)"
W !,$TR($J(" ",80)," ","-")
Q
DATE(D) ;EP
I D="" Q ""
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
;
XTMP(N,D) ;EP - set xtmp 0 node
Q:$G(N)=""
S ^XTMP(N,0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_$G(D)
Q
;
;
PURGERL ;EP - CALLED FROM OPTION
D INIT
D GETDATE
I $D(APCDQUIT) D EOJ Q
ZIS1 W !! S %ZIS="PQ" D ^%ZIS
I POP D EOJ Q
I $D(IO("Q")) D TSKMN,EOJ Q
DRIVER ;
D PURGE
W !!,"A Total of ",APCDCNT," Entries Purged.",!
D EOJ
Q
;
INIT ;
W !!,"Purge Data from Visit Relinker Log!"
S APCDCNT=0
K APCDQUIT
Q
;
GETDATE ;
S Y=DT X ^DD("DD") S APCDDTP=Y
S %DT("A")="Purge data up to and including what RELINKER RUN DATE? ",%DT="AEPX" W ! D ^%DT
I Y=-1 S APCDQUIT="" Q
S APCDPGE=Y X ^DD("DD") S APCDPGEY=Y
Q
;
PURGE ;
S APCDX=0 F S APCDX=$O(^APCDKLOG("B",APCDX)) Q:APCDX=""!(APCDX>APCDPGE) D
.S APCDY=0 F S APCDY=$O(^APCDKLOG("B",APCDX,APCDY)) Q:APCDY'=+APCDY D
..S DA=APCDY,DIK="^APCDKLOG(" D ^DIK S APCDCNT=APCDCNT+1
Q
;
;
TSKMN ;
K ZTSAVE F %="APCDPGE","APCDCNT" S ZTSAVE(%)=""
S ZTIO=ION,ZTCPU=$G(IOCPU),ZTRTN="DRIVER^APCDRLR",ZTDTH="",ZTDESC="PURGE DATA RELINKER LOG FILE" D ^%ZTLOAD
Q
EOJ ;
K APCDCNT,APCDPGE,X,Y,DIC,DA,DIE,DR,%DT,D,D0,D1,DQ,APCDDTP,APCDPGEY,POP,APCDX,APCDDUZ,APCDY
I $D(ZTQUEUED) S ZTREQ="@" K ZTSK
D ^%ZISC
Q
APCDRLR ; IHS/CMI/LAB - report of visits re-linked ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;
+3 ;
START ;EP - called from option
+1 DO XIT
+2 IF $DATA(IOF)
WRITE @IOF
+3 WRITE !!,"This option will print a list of visits on which a V File (ancillary"
+4 WRITE !,"data item was 'moved' or 're-linked' from one visit to another during the"
+5 WRITE !,"nightly visit re-linker process or during the post data entry visit re-linking"
+6 WRITE !,"process.",!
+7 WRITE !,"You will be asked to enter the date range on which the nightly"
+8 WRITE !,"visit re-linker was run.",!
+9 ;
GETDATES ;
+1 WRITE !!,"Please enter the range of dates on which the 're-linking' occurred."
BD ;get beginning date
+1 WRITE !
SET DIR(0)="D^:DT:EP"
SET DIR("A")="Enter beginning Date"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
GOTO XIT
+3 SET APCDBD=Y
ED ;get ending date
+1 WRITE !
SET DIR(0)="D^"_APCDBD_":DT:EP"
SET DIR("A")="Enter ending Date"
SET Y=APCDBD
DO DD^%DT
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
GOTO BD
+3 SET APCDED=Y
+4 SET X1=APCDBD
SET X2=-1
DO C^%DTC
SET APCDSD=X
SET Y=APCDBD
DO DD^%DT
SET APCDBDD=Y
SET Y=APCDED
DO DD^%DT
SET APCDEDD=Y
DEMO ;
+1 DO DEMOCHK^APCLUTL(.APCDDEMO)
+2 IF APCDDEMO=-1
GOTO BD
ZIS ;
+1 SET DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen"
SET DIR("A")="Do you wish to "
SET DIR("B")="P"
KILL DA
DO ^DIR
KILL DIR
+2 IF $DATA(DIRUT)
GOTO XIT
+3 IF $GET(Y)="B"
DO BROWSE
DO XIT
QUIT
+4 WRITE !!
SET XBRP="PRINT^APCDRLR"
SET XBRC="PROC^APCDRLR"
SET XBNS="APCD*"
SET XBRX="XIT^APCDRLR"
+5 DO ^XBDBQUE
+6 DO XIT
+7 QUIT
BROWSE ;
+1 SET XBRP="VIEWR^XBLM(""PRINT^APCDRLR"")"
+2 SET XBNS="APCD"
SET XBRC="PROC^APCDRLR"
SET XBRX="XIT^APCDRLR"
SET XBIOP=0
DO ^XBDBQUE
+3 QUIT
+4 ;
PROC ;EP - called from xbdbque
+1 ;loop through all visits in date range and look for problem 8-8.9 or visit type of N
+2 SET APCDJOB=$JOB
SET APCDTOT=0
SET APCDBT=$HOROLOG
+3 DO XTMP("APCDRLR","LIST FROM VISIT RELINKER")
+4 SET X1=APCDBD
SET X2=-1
DO C^%DTC
SET APCDSD=X
+5 SET APCDODAT=APCDSD_".9999"
FOR
SET APCDODAT=$ORDER(^APCDKLOG("B",APCDODAT))
IF APCDODAT=""!((APCDODAT\1)>APCDED)
QUIT
Begin DoDot:1
+6 SET APCDR=0
FOR
SET APCDR=$ORDER(^APCDKLOG("B",APCDODAT,APCDR))
IF APCDR'=+APCDR
QUIT
Begin DoDot:2
+7 SET F=$PIECE(^APCDKLOG(APCDR,0),U,5)
IF F
IF $DATA(^AUPNVSIT(F,0))
IF $$DEMO^APCLUTL($PIECE(^AUPNVSIT(F,0),U,5),APCDDEMO)
QUIT
+8 SET ^XTMP("APCDRLR",APCDJOB,APCDBT,"VISITS",APCDODAT,APCDR)=""
SET APCDTOT=APCDTOT+1
End DoDot:2
End DoDot:1
+9 QUIT
PRINT ;EP - called from xbdbque
+1 KILL APCDQ
SET APCDPG=0
+2 IF '$DATA(^XTMP("APCDRLR",APCDJOB,APCDBT,"VISITS"))
DO HEADER
WRITE !!,"There are no visits in the Visit Relinker Log for that time period.",!
QUIT
+3 DO HEADER
+4 SET APCDD=0
FOR
SET APCDD=$ORDER(^XTMP("APCDRLR",APCDJOB,APCDBT,"VISITS",APCDD))
IF APCDD=""!($DATA(APCDQ))
QUIT
Begin DoDot:1
+5 IF $Y>(IOSL-5)
DO HEADER
IF $DATA(APCDQ)
QUIT
+6 WRITE !!,"Date of Visit Relinker: ",$$FMTE^XLFDT(APCDD)
+7 SET APCDR=0
FOR
SET APCDR=$ORDER(^XTMP("APCDRLR",APCDJOB,APCDBT,"VISITS",APCDD,APCDR))
IF APCDR'=+APCDR!($DATA(APCDQ))
QUIT
Begin DoDot:2
+8 IF $Y>(IOSL-5)
DO HEADER
IF $DATA(APCDQ)
QUIT
+9 SET APCDN=^APCDKLOG(APCDR,0)
+10 SET APCDTV=$PIECE(APCDN,U,5)
+11 SET DFN=$PIECE($GET(^AUPNVSIT(APCDTV,0)),U,5)
+12 WRITE !!,$$HRN^AUPNPAT(DFN,DUZ(2)),?7,$EXTRACT($PIECE(^DPT(DFN,0),U),1,18),?25,$$FMTE^XLFDT($PIECE(^AUPNVSIT(APCDTV,0),U),2)," (",APCDTV,")",?53,$$FMTE^XLFDT($PIECE(^AUPNVSIT($PIECE(APCDN,U,4),0),U),2)," (",$PIECE(APCDN,U,4),")"
+13 WRITE !?1,"Providers-To Visit: "
+14 SET APCDX=0
SET APCDP=""
FOR
SET APCDX=$ORDER(^AUPNVPRV("AD",APCDTV,APCDX))
IF APCDX'=+APCDX!($DATA(APCDQ))
QUIT
Begin DoDot:3
+15 SET APCDPRV=$PIECE($GET(^AUPNVPRV(APCDX,0)),U)
+16 ;no provider?
IF APCDPRV=""
QUIT
+17 IF APCDP]""
SET APCDP=APCDP_"; "
+18 SET APCDP=APCDP_$EXTRACT($PIECE(^VA(200,APCDPRV,0),U,1),1,12)
End DoDot:3
+19 WRITE APCDP
+20 WRITE !?1,"Data re-linked: "
+21 KILL APCDA
SET APCDX=0
FOR
SET APCDX=$ORDER(^APCDKLOG(APCDR,11,APCDX))
IF APCDX'=+APCDX
QUIT
Begin DoDot:3
+22 SET F=$PIECE(^APCDKLOG(APCDR,11,APCDX,0),U)
SET B=$PIECE(^DIC(F,0),U)
+23 SET I=$PIECE(^APCDKLOG(APCDR,11,APCDX,0),U,2)
+24 SET P=$$VAL^XBDIQ1(F,I,1202)
IF P=""
SET P="UNKNOWN OR MISSING"
+25 SET APCDA(B,P)=$GET(APCDA(B,P))+1
End DoDot:3
+26 SET APCDX=""
SET APCDC=0
FOR
SET APCDX=$ORDER(APCDA(APCDX))
IF APCDX=""!($DATA(APCDQ))
QUIT
Begin DoDot:3
+27 SET APCDP=""
FOR
SET APCDP=$ORDER(APCDA(APCDX,APCDP))
IF APCDP=""!($DATA(APCDQ))
QUIT
Begin DoDot:4
+28 IF $Y>(IOSL-4)
DO HEADER
IF $DATA(APCDQ)
QUIT
+29 IF APCDC>0
WRITE !
WRITE ?17,$EXTRACT(APCDX,1,12),?31,"Ordering Prv: ",$EXTRACT(APCDP,1,25),?75,"# ",APCDA(APCDX,APCDP)
+30 SET APCDC=APCDC+1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+31 WRITE !!,"Total # of Visits: ",APCDTOT,!
+32 KILL ^XTMP("APCDRLR",APCDJOB,APCDBT)
XIT ;
+1 DO EN^XBVK("APCD")
+2 DO KILL^AUPNPAT
+3 QUIT
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
+1 IF 'APCDPG
GOTO HEADER1
+2 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET APCDQ=""
QUIT
+1 IF $DATA(IOF)
WRITE @IOF
SET APCDPG=APCDPG+1
+2 WRITE !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
+3 WRITE !?(80-$LENGTH($PIECE(^DIC(4,DUZ(2),0),U))/2),$PIECE(^DIC(4,DUZ(2),0),U),?($SELECT(80=132:120,1:72)),"Page ",APCDPG,!
+4 SET APCDTEXT="Visits for which an Ancillary Data Item was 're-linked' to another visit"
+5 WRITE !?(80-$LENGTH(APCDTEXT)/2),APCDTEXT,!
+6 SET APCDTEXT="Relinking Dates: "_APCDBDD_" and "_APCDEDD
+7 WRITE ?(80-$LENGTH(APCDTEXT)/2),APCDTEXT,!
+8 WRITE $TRANSLATE($JUSTIFY(" ",80)," ","-")
+9 WRITE !,?25,"TO VISIT",?53,"FROM VISIT"
+10 WRITE !,"HRN",?7,"PATIENT",?25,"DATE/TIME (IEN)",?53,"DATE/TIME (IEN)"
+11 WRITE !,$TRANSLATE($JUSTIFY(" ",80)," ","-")
+12 QUIT
DATE(D) ;EP
+1 IF D=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)
+3 ;
XTMP(N,D) ;EP - set xtmp 0 node
+1 IF $GET(N)=""
QUIT
+2 SET ^XTMP(N,0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_$GET(D)
+3 QUIT
+4 ;
+5 ;
PURGERL ;EP - CALLED FROM OPTION
+1 DO INIT
+2 DO GETDATE
+3 IF $DATA(APCDQUIT)
DO EOJ
QUIT
ZIS1 WRITE !!
SET %ZIS="PQ"
DO ^%ZIS
+1 IF POP
DO EOJ
QUIT
+2 IF $DATA(IO("Q"))
DO TSKMN
DO EOJ
QUIT
DRIVER ;
+1 DO PURGE
+2 WRITE !!,"A Total of ",APCDCNT," Entries Purged.",!
+3 DO EOJ
+4 QUIT
+5 ;
INIT ;
+1 WRITE !!,"Purge Data from Visit Relinker Log!"
+2 SET APCDCNT=0
+3 KILL APCDQUIT
+4 QUIT
+5 ;
GETDATE ;
+1 SET Y=DT
XECUTE ^DD("DD")
SET APCDDTP=Y
+2 SET %DT("A")="Purge data up to and including what RELINKER RUN DATE? "
SET %DT="AEPX"
WRITE !
DO ^%DT
+3 IF Y=-1
SET APCDQUIT=""
QUIT
+4 SET APCDPGE=Y
XECUTE ^DD("DD")
SET APCDPGEY=Y
+5 QUIT
+6 ;
PURGE ;
+1 SET APCDX=0
FOR
SET APCDX=$ORDER(^APCDKLOG("B",APCDX))
IF APCDX=""!(APCDX>APCDPGE)
QUIT
Begin DoDot:1
+2 SET APCDY=0
FOR
SET APCDY=$ORDER(^APCDKLOG("B",APCDX,APCDY))
IF APCDY'=+APCDY
QUIT
Begin DoDot:2
+3 SET DA=APCDY
SET DIK="^APCDKLOG("
DO ^DIK
SET APCDCNT=APCDCNT+1
End DoDot:2
End DoDot:1
+4 QUIT
+5 ;
+6 ;
TSKMN ;
+1 KILL ZTSAVE
FOR %="APCDPGE","APCDCNT"
SET ZTSAVE(%)=""
+2 SET ZTIO=ION
SET ZTCPU=$GET(IOCPU)
SET ZTRTN="DRIVER^APCDRLR"
SET ZTDTH=""
SET ZTDESC="PURGE DATA RELINKER LOG FILE"
DO ^%ZTLOAD
+3 QUIT
EOJ ;
+1 KILL APCDCNT,APCDPGE,X,Y,DIC,DA,DIE,DR,%DT,D,D0,D1,DQ,APCDDTP,APCDPGEY,POP,APCDX,APCDDUZ,APCDY
+2 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL ZTSK
+3 DO ^%ZISC
+4 QUIT
