APCLPDEM ; 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 all visits for your 'DEMO' patients."
W !,"The patient visits listed are those for patients whose name begins with"
W !,"DEMO,PATIENT or who reside in your site defined DEMO patient search template."
W !!,"You can use this list to delete the visits using the data entry delete"
W !,"visit option."
W !
;
GETDATES ;
W !!,"Please enter the range of visit dates for the demo patients."
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 APCLBD=Y
ED ;get ending date
W ! S DIR(0)="D^"_APCLBD_":DT:EP",DIR("A")="Enter ending Date" S Y=APCLBD D DD^%DT D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) G BD
S APCLED=Y
S X1=APCLBD,X2=-1 D C^%DTC S APCLSD=X S Y=APCLBD D DD^%DT S APCLBDD=Y S Y=APCLED D DD^%DT S APCLEDD=Y
ZIS ;
DEMO ;
D DEMOCHK^APCLUTL(.APCLDEMO)
I APCLDEMO=-1 G GETDATES
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^APCLPDEM",XBRC="PROC^APCLPDEM",XBNS="APCL*",XBRX="XIT^APCLPDEM"
D ^XBDBQUE
D XIT
Q
BROWSE ;
S XBRP="VIEWR^XBLM(""PRINT^APCLPDEM"")"
S XBNS="APCL",XBRC="PROC^APCLPDEM",XBRX="XIT^APCLPDEM",XBIOP=0 D ^XBDBQUE
Q
;
PROC ;EP - called from xbdbque
;loop through all visits in date range and look for DEMO patient visits
S APCLJOB=$J,APCLTOT=0,APCLBT=$H
D XTMP("APCLPDEM","DEMO PATIENT VISIT LIST")
S X1=APCLBD,X2=-1 D C^%DTC S APCLSD=X
S APCLODAT=APCLSD_".9999" F S APCLODAT=$O(^AUPNVSIT("B",APCLODAT)) Q:APCLODAT=""!((APCLODAT\1)>APCLED) D
.S APCLV=0 F S APCLV=$O(^AUPNVSIT("B",APCLODAT,APCLV)) Q:APCLV'=+APCLV D
..Q:$P(^AUPNVSIT(APCLV,0),U,11)
..Q:$P(^AUPNVSIT(APCLV,0),U,5)=""
..Q:$$DEMO^APCLUTL($P(^AUPNVSIT(APCLV,0),U,5),$G(APCLDEMO))
..S ^XTMP("APCLPDEM",APCLJOB,APCLBT,"VISITS",$P(^AUPNVSIT(APCLV,0),U,5),APCLV)="",APCLTOT=APCLTOT+1
Q
PRINT ;EP - called from xbdbque
K APCLQ S APCLPG=0
I '$D(^XTMP("APCLPDEM",APCLJOB,APCLBT,"VISITS")) D HEADER W !!,"There are no Demo patient visits for that time period.",! Q
D HEADER
S APCLP=0 F S APCLP=$O(^XTMP("APCLPDEM",APCLJOB,APCLBT,"VISITS",APCLP)) Q:APCLP=""!($D(APCLQ)) D
.S APCLV=0 F S APCLV=$O(^XTMP("APCLPDEM",APCLJOB,APCLBT,"VISITS",APCLP,APCLV)) Q:APCLV'=+APCLV!($D(APCLQ)) D
..I $Y>(IOSL-4) D HEADER Q:$D(APCLQ)
..W !,$$HRN^AUPNPAT(APCLP,DUZ(2)),?7,$E($P(^DPT(APCLP,0),U),1,22),?29,$$FMTE^XLFDT($P(^AUPNVSIT(APCLV,0),U),1)," (",APCLV,")",?62,$P(^AUPNVSIT(APCLV,0),U,3),?65,$P(^AUPNVSIT(APCLV,0),U,7),?68,$E($$CLINIC^APCLV(APCLV,"E"),1,12)
W !!,"Total # of Visits: ",APCLTOT,!
K ^XTMP("APCLPDEM",APCLJOB,APCLBT)
XIT ;
D EN^XBVK("APCL")
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 'APCLPG 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 APCLQ="" Q
W:$D(IOF) @IOF S APCLPG=APCLPG+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 ",APCLPG,!
S APCLTEXT="'DEMO' PATIENT VISITS"
W !?(80-$L(APCLTEXT)/2),APCLTEXT,!
S APCLTEXT="Visit Dates: "_APCLBDD_" and "_APCLEDD
W ?(80-$L(APCLTEXT)/2),APCLTEXT,!
W $TR($J(" ",80)," ","-")
W !,"HRN",?7,"PATIENT",?32,"DATE/TIME (IEN)",?60,"TYPE",?65,"SC",?68,"CLINIC"
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
;
;
APCLPDEM ; 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 all visits for your 'DEMO' patients."
+4 WRITE !,"The patient visits listed are those for patients whose name begins with"
+5 WRITE !,"DEMO,PATIENT or who reside in your site defined DEMO patient search template."
+6 WRITE !!,"You can use this list to delete the visits using the data entry delete"
+7 WRITE !,"visit option."
+8 WRITE !
+9 ;
GETDATES ;
+1 WRITE !!,"Please enter the range of visit dates for the demo patients."
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 APCLBD=Y
ED ;get ending date
+1 WRITE !
SET DIR(0)="D^"_APCLBD_":DT:EP"
SET DIR("A")="Enter ending Date"
SET Y=APCLBD
DO DD^%DT
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
GOTO BD
+3 SET APCLED=Y
+4 SET X1=APCLBD
SET X2=-1
DO C^%DTC
SET APCLSD=X
SET Y=APCLBD
DO DD^%DT
SET APCLBDD=Y
SET Y=APCLED
DO DD^%DT
SET APCLEDD=Y
ZIS ;
DEMO ;
+1 DO DEMOCHK^APCLUTL(.APCLDEMO)
+2 IF APCLDEMO=-1
GOTO GETDATES
+3 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
+4 IF $DATA(DIRUT)
GOTO XIT
+5 IF $GET(Y)="B"
DO BROWSE
DO XIT
QUIT
+6 WRITE !!
SET XBRP="PRINT^APCLPDEM"
SET XBRC="PROC^APCLPDEM"
SET XBNS="APCL*"
SET XBRX="XIT^APCLPDEM"
+7 DO ^XBDBQUE
+8 DO XIT
+9 QUIT
BROWSE ;
+1 SET XBRP="VIEWR^XBLM(""PRINT^APCLPDEM"")"
+2 SET XBNS="APCL"
SET XBRC="PROC^APCLPDEM"
SET XBRX="XIT^APCLPDEM"
SET XBIOP=0
DO ^XBDBQUE
+3 QUIT
+4 ;
PROC ;EP - called from xbdbque
+1 ;loop through all visits in date range and look for DEMO patient visits
+2 SET APCLJOB=$JOB
SET APCLTOT=0
SET APCLBT=$HOROLOG
+3 DO XTMP("APCLPDEM","DEMO PATIENT VISIT LIST")
+4 SET X1=APCLBD
SET X2=-1
DO C^%DTC
SET APCLSD=X
+5 SET APCLODAT=APCLSD_".9999"
FOR
SET APCLODAT=$ORDER(^AUPNVSIT("B",APCLODAT))
IF APCLODAT=""!((APCLODAT\1)>APCLED)
QUIT
Begin DoDot:1
+6 SET APCLV=0
FOR
SET APCLV=$ORDER(^AUPNVSIT("B",APCLODAT,APCLV))
IF APCLV'=+APCLV
QUIT
Begin DoDot:2
+7 IF $PIECE(^AUPNVSIT(APCLV,0),U,11)
QUIT
+8 IF $PIECE(^AUPNVSIT(APCLV,0),U,5)=""
QUIT
+9 IF $$DEMO^APCLUTL($PIECE(^AUPNVSIT(APCLV,0),U,5),$GET(APCLDEMO))
QUIT
+10 SET ^XTMP("APCLPDEM",APCLJOB,APCLBT,"VISITS",$PIECE(^AUPNVSIT(APCLV,0),U,5),APCLV)=""
SET APCLTOT=APCLTOT+1
End DoDot:2
End DoDot:1
+11 QUIT
PRINT ;EP - called from xbdbque
+1 KILL APCLQ
SET APCLPG=0
+2 IF '$DATA(^XTMP("APCLPDEM",APCLJOB,APCLBT,"VISITS"))
DO HEADER
WRITE !!,"There are no Demo patient visits for that time period.",!
QUIT
+3 DO HEADER
+4 SET APCLP=0
FOR
SET APCLP=$ORDER(^XTMP("APCLPDEM",APCLJOB,APCLBT,"VISITS",APCLP))
IF APCLP=""!($DATA(APCLQ))
QUIT
Begin DoDot:1
+5 SET APCLV=0
FOR
SET APCLV=$ORDER(^XTMP("APCLPDEM",APCLJOB,APCLBT,"VISITS",APCLP,APCLV))
IF APCLV'=+APCLV!($DATA(APCLQ))
QUIT
Begin DoDot:2
+6 IF $Y>(IOSL-4)
DO HEADER
IF $DATA(APCLQ)
QUIT
+7 WRITE !,$$HRN^AUPNPAT(APCLP,DUZ(2)),?7,$EXTRACT($PIECE(^DPT(APCLP,0),U),1,22),?29,$$FMTE^XLFDT($PIECE(^AUPNVSIT(APCLV,0),U),1)," (",APCLV,")",?62,$PIECE(^AUPNVSIT(APCLV,0),U,3),?65,$PIECE(^AUPNVSIT(APCLV,0),U,7),?68,$EXTRACT($$C
LINIC^APCLV(APCLV,"E"),1,12)
End DoDot:2
End DoDot:1
+8 WRITE !!,"Total # of Visits: ",APCLTOT,!
+9 KILL ^XTMP("APCLPDEM",APCLJOB,APCLBT)
XIT ;
+1 DO EN^XBVK("APCL")
+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 'APCLPG
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 APCLQ=""
QUIT
+1 IF $DATA(IOF)
WRITE @IOF
SET APCLPG=APCLPG+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 ",APCLPG,!
+4 SET APCLTEXT="'DEMO' PATIENT VISITS"
+5 WRITE !?(80-$LENGTH(APCLTEXT)/2),APCLTEXT,!
+6 SET APCLTEXT="Visit Dates: "_APCLBDD_" and "_APCLEDD
+7 WRITE ?(80-$LENGTH(APCLTEXT)/2),APCLTEXT,!
+8 WRITE $TRANSLATE($JUSTIFY(" ",80)," ","-")
+9 WRITE !,"HRN",?7,"PATIENT",?32,"DATE/TIME (IEN)",?60,"TYPE",?65,"SC",?68,"CLINIC"
+10 WRITE !,$TRANSLATE($JUSTIFY(" ",80)," ","-")
+11 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 ;
