SDSCNSCP.m

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