SDSCNSCP ;ALB/JAM - ASCD NSC Encounters Purge ; 4/24/07 4:29pm
;;5.3;Scheduling;**495,1015**;Aug 13, 1993;Build 21
;
;**Program Description**
; This program will purge encounters with a status of NEW where
; the Visit SC value equals the ASCD value of "NO" for a specified
; division(s) with and a user defined date range. Users must have
; the SDSC SUPER key to run this option.
Q
EN ; Entry Point
N ZTQUEUED,POP,ZTRTN,ZTDTH,ZTDESC,ZTSAVE,SDSCDVSL,SDSCDVLN,DIR,X,Y
N DTOUT,DUOUT
; Get start and end date for encounter list.
D GETDATE^SDSCOMP I SDSCTDT="" G EXIT
; Ask for division
D DIV^SDSCUTL
D ^DIR
I $G(DTOUT)!($G(DUOUT)) G EXIT
S SDSCDVSL=Y,SDSCDVLN=SCLN
K SCLN,DIR
; Determine type of user
D TYPE^SDSCUTL
I SDTYPE'="S" W !!,"You do not have privileges to run this report." Q
W !!,"This option will permanently remove the outpatient encounters that are at a"
W !,"NEW status when both the Encounter SC value and the ASCD value are 'NO' from"
W !,"the SDSC SERVICE CONNECTED CHANGES file (#409.48).",!
S DIR(0)="Y",DIR("A")="Are you sure you want to continue",DIR("B")="N"
S DIR("?")="YES to remove encounters from the Review file, NO to Exit."
D ^DIR
I ('Y)!($G(DTOUT))!($G(DUOUT)) G EXIT
;
K %ZIS,IOP,IOC,ZTIO S %ZIS="QM" D ^%ZIS G:POP EXIT
I $D(IO("Q")) D G EXIT
. S ZTRTN="BEG^SDSCNSCP",ZTDTH=$H,ZTDESC="Purge ASCD NSC Encounters"
. S ZTSAVE("SDSCDVSL")="",ZTSAVE("SDSCDVLN")="",ZTSAVE("SDEDT")=""
. S ZTSAVE("SDSCTDT")="",ZTIO=ION
. K IO("Q") D ^%ZTLOAD W !,"REQUEST QUEUED"
;
BEG ; Begin report
N SDSCDIV,SDSCDNM,SDI,SDGTOT,SDPG
S SDGTOT=0,SDPG=1
S SDSCDIV=$S(SDSCDVSL'[SDSCDVLN:SDSCDVSL,1:"")
I SDSCDIV="" S SDSCDNM="ALL" D FND G EXIT
I SDSCDIV'="" D
. F SDI=1:1:$L(SDSCDVSL,",") S SDSCDIV=$P(SDSCDVSL,",",SDI) Q:SDSCDIV="" D
.. S SDSCDNM=$P(^DG(40.8,SDSCDIV,0),"^",1)
.. D FND
W !!,"Grand total of NSC Records Purged: ",SDGTOT
G EXIT
;
FND ; Find records and delete
N SDOEDT,SDOE0,SDEDIV,SDOE,SDSCDATA,SDL,SDV0,SDPRV,SCVST,SDCNT,DFN,DIK,DA
;
D HDR
S SDOEDT=SDSCTDT-1,(SDL,SDCNT)=0
F S SDOEDT=$O(^SDSC(409.48,"AE",SDOEDT)) Q:SDOEDT\1>SDEDT!(SDOEDT="") D
. S SDOE=""
. F S SDOE=$O(^SDSC(409.48,"AE",SDOEDT,SDOE)) Q:SDOE="" D
.. S SDOE0=$$GETOE^SDOE(SDOE),SDSCDATA=$G(^SDSC(409.48,SDOE,0))
.. Q:SDOE0="" Q:SDSCDATA=""
.. ; Check if status is NEW
.. I $P(SDSCDATA,U,5)'="N" Q
.. S SDEDIV=$P(SDSCDATA,U,12) Q:SDEDIV=""
.. I SDSCDIV'="" Q:SDEDIV'=SDSCDIV
.. ; Check for ASCD SC value
.. I $P(SDSCDATA,U,9)'=0 Q
.. ; Check for Visit SC value
.. S SDV0=$P(SDOE0,U,5),SCVST=$$GET1^DIQ(9000010,SDV0_",",80001,"I")
.. I SCVST'=0 Q
.. S DFN=$P(SDOE0,U,"2Z") D DEM^VADPT
.. S SDCNT=SDCNT+1,SDGTOT=SDGTOT+1,SCVST=$S(SCVST:"Y",SCVST=0:"NO",1:"")
.. S SDPRV=$$GET1^DIQ(200,$$PRIMVPRV^PXUTL1(SDV0)_",",.01,"E"),SDL=SDL+1
.. W !,$$FMTE^XLFDT(SDOEDT,2),?16,SDOE,?30,$E(VADM(1),1,25),?55,$E(SDPRV,1,19),?75,SCVST
.. S DIK="^SDSC(409.48,",DA=SDOE D ^DIK
.. D KVA^VADPT
.. I $E(IOST,1,2)'="C-",SDL+4>IOSL D HDR
W !!,"Number of NSC Records Purged: ",SDCNT," for "_SDSCDNM
Q
;
HDR ; Print report
N SDHDR,I
S SDHDR="Purge ASCD NSC Encounters"
W @IOF
W SDHDR,?67,"PAGE: ",SDPG
W !,?5,"For Encounters Dated ",$$FMTE^XLFDT(SDSCTDT,2)," THRU ",$$FMTE^XLFDT(SDEDT,2)," For Division: ",SDSCDNM,!!
W "Encounter Date",?16,"Encounter No.",?30,"Patient Name",?55,"Provider",?73,"SC Val"
W ! F I=1:1:79 W "-"
S SDPG=SDPG+1
Q
;
EXIT ;clean up variables before exiting option
K SDEDT,SDOPT,SDSCBDT,SDSCCR,SDSCEDT,SDSCTAT,SDSCTDT,SDTYPE
Q
SDSCNSCP ;ALB/JAM - ASCD NSC Encounters Purge ; 4/24/07 4:29pm
+1 ;;5.3;Scheduling;**495,1015**;Aug 13, 1993;Build 21
+2 ;
+3 ;**Program Description**
+4 ; This program will purge encounters with a status of NEW where
+5 ; the Visit SC value equals the ASCD value of "NO" for a specified
+6 ; division(s) with and a user defined date range. Users must have
+7 ; the SDSC SUPER key to run this option.
+8 QUIT
EN ; Entry Point
+1 NEW ZTQUEUED,POP,ZTRTN,ZTDTH,ZTDESC,ZTSAVE,SDSCDVSL,SDSCDVLN,DIR,X,Y
+2 NEW DTOUT,DUOUT
+3 ; Get start and end date for encounter list.
+4 DO GETDATE^SDSCOMP
IF SDSCTDT=""
GOTO EXIT
+5 ; Ask for division
+6 DO DIV^SDSCUTL
+7 DO ^DIR
+8 IF $GET(DTOUT)!($GET(DUOUT))
GOTO EXIT
+9 SET SDSCDVSL=Y
SET SDSCDVLN=SCLN
+10 KILL SCLN,DIR
+11 ; Determine type of user
+12 DO TYPE^SDSCUTL
+13 IF SDTYPE'="S"
WRITE !!,"You do not have privileges to run this report."
QUIT
+14 WRITE !!,"This option will permanently remove the outpatient encounters that are at a"
+15 WRITE !,"NEW status when both the Encounter SC value and the ASCD value are 'NO' from"
+16 WRITE !,"the SDSC SERVICE CONNECTED CHANGES file (#409.48).",!
+17 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to continue"
SET DIR("B")="N"
+18 SET DIR("?")="YES to remove encounters from the Review file, NO to Exit."
+19 DO ^DIR
+20 IF ('Y)!($GET(DTOUT))!($GET(DUOUT))
GOTO EXIT
+21 ;
+22 KILL %ZIS,IOP,IOC,ZTIO
SET %ZIS="QM"
DO ^%ZIS
IF POP
GOTO EXIT
+23 IF $DATA(IO("Q"))
Begin DoDot:1
+24 SET ZTRTN="BEG^SDSCNSCP"
SET ZTDTH=$HOROLOG
SET ZTDESC="Purge ASCD NSC Encounters"
+25 SET ZTSAVE("SDSCDVSL")=""
SET ZTSAVE("SDSCDVLN")=""
SET ZTSAVE("SDEDT")=""
+26 SET ZTSAVE("SDSCTDT")=""
SET ZTIO=ION
+27 KILL IO("Q")
DO ^%ZTLOAD
WRITE !,"REQUEST QUEUED"
End DoDot:1
GOTO EXIT
+28 ;
BEG ; Begin report
+1 NEW SDSCDIV,SDSCDNM,SDI,SDGTOT,SDPG
+2 SET SDGTOT=0
SET SDPG=1
+3 SET SDSCDIV=$SELECT(SDSCDVSL'[SDSCDVLN:SDSCDVSL,1:"")
+4 IF SDSCDIV=""
SET SDSCDNM="ALL"
DO FND
GOTO EXIT
+5 IF SDSCDIV'=""
Begin DoDot:1
+6 FOR SDI=1:1:$LENGTH(SDSCDVSL,",")
SET SDSCDIV=$PIECE(SDSCDVSL,",",SDI)
IF SDSCDIV=""
QUIT
Begin DoDot:2
+7 SET SDSCDNM=$PIECE(^DG(40.8,SDSCDIV,0),"^",1)
+8 DO FND
End DoDot:2
End DoDot:1
+9 WRITE !!,"Grand total of NSC Records Purged: ",SDGTOT
+10 GOTO EXIT
+11 ;
FND ; Find records and delete
+1 NEW SDOEDT,SDOE0,SDEDIV,SDOE,SDSCDATA,SDL,SDV0,SDPRV,SCVST,SDCNT,DFN,DIK,DA
+2 ;
+3 DO HDR
+4 SET SDOEDT=SDSCTDT-1
SET (SDL,SDCNT)=0
+5 FOR
SET SDOEDT=$ORDER(^SDSC(409.48,"AE",SDOEDT))
IF SDOEDT\1>SDEDT!(SDOEDT="")
QUIT
Begin DoDot:1
+6 SET SDOE=""
+7 FOR
SET SDOE=$ORDER(^SDSC(409.48,"AE",SDOEDT,SDOE))
IF SDOE=""
QUIT
Begin DoDot:2
+8 SET SDOE0=$$GETOE^SDOE(SDOE)
SET SDSCDATA=$GET(^SDSC(409.48,SDOE,0))
+9 IF SDOE0=""
QUIT
IF SDSCDATA=""
QUIT
+10 ; Check if status is NEW
+11 IF $PIECE(SDSCDATA,U,5)'="N"
QUIT
+12 SET SDEDIV=$PIECE(SDSCDATA,U,12)
IF SDEDIV=""
QUIT
+13 IF SDSCDIV'=""
IF SDEDIV'=SDSCDIV
QUIT
+14 ; Check for ASCD SC value
+15 IF $PIECE(SDSCDATA,U,9)'=0
QUIT
+16 ; Check for Visit SC value
+17 SET SDV0=$PIECE(SDOE0,U,5)
SET SCVST=$$GET1^DIQ(9000010,SDV0_",",80001,"I")
+18 IF SCVST'=0
QUIT
+19 SET DFN=$PIECE(SDOE0,U,"2Z")
DO DEM^VADPT
+20 SET SDCNT=SDCNT+1
SET SDGTOT=SDGTOT+1
SET SCVST=$SELECT(SCVST:"Y",SCVST=0:"NO",1:"")
+21 SET SDPRV=$$GET1^DIQ(200,$$PRIMVPRV^PXUTL1(SDV0)_",",.01,"E")
SET SDL=SDL+1
+22 WRITE !,$$FMTE^XLFDT(SDOEDT,2),?16,SDOE,?30,$EXTRACT(VADM(1),1,25),?55,$EXTRACT(SDPRV,1,19),?75,SCVST
+23 SET DIK="^SDSC(409.48,"
SET DA=SDOE
DO ^DIK
+24 DO KVA^VADPT
+25 IF $EXTRACT(IOST,1,2)'="C-"
IF SDL+4>IOSL
DO HDR
End DoDot:2
End DoDot:1
+26 WRITE !!,"Number of NSC Records Purged: ",SDCNT," for "_SDSCDNM
+27 QUIT
+28 ;
HDR ; Print report
+1 NEW SDHDR,I
+2 SET SDHDR="Purge ASCD NSC Encounters"
+3 WRITE @IOF
+4 WRITE SDHDR,?67,"PAGE: ",SDPG
+5 WRITE !,?5,"For Encounters Dated ",$$FMTE^XLFDT(SDSCTDT,2)," THRU ",$$FMTE^XLFDT(SDEDT,2)," For Division: ",SDSCDNM,!!
+6 WRITE "Encounter Date",?16,"Encounter No.",?30,"Patient Name",?55,"Provider",?73,"SC Val"
+7 WRITE !
FOR I=1:1:79
WRITE "-"
+8 SET SDPG=SDPG+1
+9 QUIT
+10 ;
EXIT ;clean up variables before exiting option
+1 KILL SDEDT,SDOPT,SDSCBDT,SDSCCR,SDSCEDT,SDSCTAT,SDSCTDT,SDTYPE
+2 QUIT
