ADGDSIP.m

ADGDSIP ; IHS/ADC/PDW/ENM - DS CHART DEFICIENCY BY PROV ; [ 03/25/1999  11:48 AM ]

 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999

 ;

 K ^TMP("DGZICPL",$J)

A ;--main

 NEW DGRNG

 D DELDT,HDH,PROV I $D(DIRUT) D Q Q

 D COPY I $D(DIRUT) D Q Q

 D SUMM I $D(DIRUT)!(Y=-1) D Q Q

 D SCRN I $D(DIRUT) D Q Q

 D DEV I POP D Q Q

 I $D(IO("Q")) D QUE,Q Q

 D:'DGPR PA D:DGPR P1 D ^ADGDSIP1,Q

 Q

 ;

DELDT ;--delinquent chart date (today-(30days+holidaydays))

 N X,Y,X1,X2 S DGRNG=$P($G(^DG(43,1,9999999.02)),U,3)

 S X1=DT,X2=-$S(DGRNG:DGRNG,1:30) D C^%DTC

 F Y=0:0 S X=$O(^HOLIDAY(X)) Q:'X!(X>DT)  S Y=Y+1

 S X1=DT,X2=-$S(DGRNG:DGRNG,1:30)-Y D C^%DTC S DGDEL=X Q

 ;

HDH ;--intro

 W !!!?23,"Chart Deficiency List By Provider",!!

 W !!?10,"Charts with a surgery date earlier than "

 W !?29,$E(DGDEL,4,5)_"/"_$E(DGDEL,6,7)_"/"_$E(DGDEL,2,3)

 W !?15,"will be considered delinquent! (",DGRNG," days)"

 Q

 ;

PROV ;--all providers or just one?

 K DIR S DIR("A")="For All Providers",DIR(0)="Y",DIR("B")="YES"

 S DIR("?",1)="Answer YES to print the list for all providers."

 S DIR("?",2)="Answer NO to select sort logic.",DIR("?")=" "

 S (DGSCN,DGOPT,DGPR)=0 D ^DIR Q:Y  Q:$D(DIRUT)

 ;--select option

 W !!,"(1) for a Service",!,"(2) for a Class",!,"(3) for a Provider"

 K DIR S DIR("A")="Which Option (number)",DIR(0)="N^1:3"

 D ^DIR S DGOPT=+Y  Q:$D(DIRUT)

 ;--class

 I DGOPT=2 D  Q

 . K DIR S DIR("A")="Which Class",DIR(0)="P^7:EQZM"

 . D ^DIR S DGSCN=+Y

 ;--specialty

 I DGOPT=1 D  Q

 . K DIR S DIR("A")="Which Specialty",DIR(0)="P^45.7:EQZM"

 . D ^DIR S DGSCN=+Y

 ;--select provider

 K DIC S DIC("A")="Which Provider:  ",DIC=200,DIC(0)="AEQZM"

 S DIC("S")="I $D(^XUSEC(""PROVIDER"",+Y))"

 D ^DIC S DGPR=+Y Q

 ;

COPY ;--number of copies

 K DIR S DIR("A")="How Many Copies",DIR(0)="N^1:10",DIR("B")=1

 D ^DIR S DGNUM=Y Q

 ;

SUMM ;--print summaries at end of each provider?

 W !!,"Include in Report:",!,"(1) Individual Provider Lists Only"

 W !,"(2) Summary Page Only",!,"(3) BOTH"

 K DIR S DIR(0)="N^1:3",DIR("A")="Choose number"

 D ^DIR S DGSUMPG=Y Q

 ;

SCRN ;--include awaiting trans deficiency?

 K DIR S DIR(0)="Y",DIR("B")="NO"

 S DIR("A")="Include 'AWAITING TRANS' deficiencies"

 D ^DIR S DGSCRN='Y Q

 ;

DEV ;--device selection

 S %ZIS="PQ" D ^%ZIS Q

 ;

QUE ;--queued output     

 K IO("Q") S ZTRTN="EN^ADGDSIP",ZTDESC="PRINT CHART DEFICIENCY LIST"

 N I F I="DGPR","DGDEL","DGNUM","DGSUMPG","DGSCRN","DGOPT","DGSCN" S ZTSAVE(I)=""

 D ^%ZTLOAD,^%ZISC K ZTSK Q

 ;

EN ;EP; --queued entry point

 D:'DGPR PA D:DGPR P1 D ^ADGDSIP1,Q Q

 ;

PA ;--all providers

 F  S DGPR=$O(^ADGDSI("AC",DGPR)) Q:'DGPR  D

 . I DGOPT=2 D:$P($G(^VA(200,+DGPR,"PS")),U,5)=DGSCN P1 Q

 . D P1

 Q

 ;

P1 ;--one provider

 N DFN,DS,PM

 S DFN=0 F  S DFN=$O(^ADGDSI("AC",DGPR,DFN)) Q:'DFN  D

 . F DS=0:0 S DS=$O(^ADGDSI("AC",DGPR,DFN,DS)) Q:'DS  D

 .. I DGOPT=1,$P($G(^ADGDSI(DFN,"DT",DS,0)),U,5)'=DGSCN Q

 .. F PM=0:0 S PM=$O(^ADGDSI("AC",DGPR,DFN,DS,PM)) Q:'PM  D 1

 Q

 ;

1 ;

 NEW NM,CHT,N,SUM,OPD,OPR,PRN,CD,DSD

 S NM=$P($G(^DPT(DFN,0)),U),CHT=$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)

 ;discharge date ;date summary dictated ;date op report dictated

 S N=$G(^ADGDSI(DFN,"DT",DS,0)) Q:N=""

 S DSD=$P(N,U),OPD=$P(N,U,2),OPR=$P(N,U,3)

 S PRN=$P($G(^VA(200,+DGPR,0)),U)

 ;--chart deficiencies

 N X,X1 S CD="",X=0

 F  S X=$O(^ADGDSI(DFN,"DT",DS,"P",PM,"CD",X)) Q:'X  D

 . S X1=$P(^ADGDSI(DFN,"DT",DS,"P",PM,"CD",X,0),U)

 . I DGSCRN Q:^ADGCD(X1,0)["AWAITING TRANS"

 . S CD=$S(CD="":X1,1:CD_U_X1)

 ;--utility

 Q:CD=""  S ^TMP("DGZICPL",$J,PRN,DSD,NM,DFN)=CHT_U_OPD_U_OPR_U_CD Q

 ;

Q ;--cleanup

 K DGPR,DIR,POP,DGFLG,DGDEL,DGSUMPG,DGSCRN,DGNUM,DGOPT,DGSCN

 D HOME^%ZIS Q

ADGDSIP   ; IHS/ADC/PDW/ENM - DS CHART DEFICIENCY BY PROV ; [ 03/25/1999  11:48 AM ]

 +1       ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999

 +2       ;

 +3        KILL ^TMP("DGZICPL",$JOB)

A         ;--main

 +1        NEW DGRNG

 +2        DO DELDT

           DO HDH

           DO PROV

           IF $DATA(DIRUT)

               DO Q

               QUIT 

 +3        DO COPY

           IF $DATA(DIRUT)

               DO Q

               QUIT 

 +4        DO SUMM

           IF $DATA(DIRUT)!(Y=-1)

               DO Q

               QUIT 

 +5        DO SCRN

           IF $DATA(DIRUT)

               DO Q

               QUIT 

 +6        DO DEV

           IF POP

               DO Q

               QUIT 

 +7        IF $DATA(IO("Q"))

               DO QUE

               DO Q

               QUIT 

 +8        IF 'DGPR

               DO PA

           IF DGPR

               DO P1

           DO ^ADGDSIP1

           DO Q

 +9        QUIT 

 +10      ;

DELDT     ;--delinquent chart date (today-(30days+holidaydays))

 +1        NEW X,Y,X1,X2

           SET DGRNG=$PIECE($GET(^DG(43,1,9999999.02)),U,3)

 +2        SET X1=DT

           SET X2=-$SELECT(DGRNG:DGRNG,1:30)

           DO C^%DTC

 +3        FOR Y=0:0

               SET X=$ORDER(^HOLIDAY(X))

               IF 'X!(X>DT)

                   QUIT 

               SET Y=Y+1

 +4        SET X1=DT

           SET X2=-$SELECT(DGRNG:DGRNG,1:30)-Y

           DO C^%DTC

           SET DGDEL=X

           QUIT 

 +5       ;

HDH       ;--intro

 +1        WRITE !!!?23,"Chart Deficiency List By Provider",!!

 +2        WRITE !!?10,"Charts with a surgery date earlier than "

 +3        WRITE !?29,$EXTRACT(DGDEL,4,5)_"/"_$EXTRACT(DGDEL,6,7)_"/"_$EXTRACT(DGDEL,2,3)

 +4        WRITE !?15,"will be considered delinquent! (",DGRNG," days)"

 +5        QUIT 

 +6       ;

PROV      ;--all providers or just one?

 +1        KILL DIR

           SET DIR("A")="For All Providers"

           SET DIR(0)="Y"

           SET DIR("B")="YES"

 +2        SET DIR("?",1)="Answer YES to print the list for all providers."

 +3        SET DIR("?",2)="Answer NO to select sort logic."

           SET DIR("?")=" "

 +4        SET (DGSCN,DGOPT,DGPR)=0

           DO ^DIR

           IF Y

               QUIT 

           IF $DATA(DIRUT)

               QUIT 

 +5       ;--select option

 +6        WRITE !!,"(1) for a Service",!,"(2) for a Class",!,"(3) for a Provider"

 +7        KILL DIR

           SET DIR("A")="Which Option (number)"

           SET DIR(0)="N^1:3"

 +8        DO ^DIR

           SET DGOPT=+Y

           IF $DATA(DIRUT)

               QUIT 

 +9       ;--class

 +10       IF DGOPT=2

               Begin DoDot:1

 +11               KILL DIR

                   SET DIR("A")="Which Class"

                   SET DIR(0)="P^7:EQZM"

 +12               DO ^DIR

                   SET DGSCN=+Y

               End DoDot:1

               QUIT 

 +13      ;--specialty

 +14       IF DGOPT=1

               Begin DoDot:1

 +15               KILL DIR

                   SET DIR("A")="Which Specialty"

                   SET DIR(0)="P^45.7:EQZM"

 +16               DO ^DIR

                   SET DGSCN=+Y

               End DoDot:1

               QUIT 

 +17      ;--select provider

 +18       KILL DIC

           SET DIC("A")="Which Provider:  "

           SET DIC=200

           SET DIC(0)="AEQZM"

 +19       SET DIC("S")="I $D(^XUSEC(""PROVIDER"",+Y))"

 +20       DO ^DIC

           SET DGPR=+Y

           QUIT 

 +21      ;

COPY      ;--number of copies

 +1        KILL DIR

           SET DIR("A")="How Many Copies"

           SET DIR(0)="N^1:10"

           SET DIR("B")=1

 +2        DO ^DIR

           SET DGNUM=Y

           QUIT 

 +3       ;

SUMM      ;--print summaries at end of each provider?

 +1        WRITE !!,"Include in Report:",!,"(1) Individual Provider Lists Only"

 +2        WRITE !,"(2) Summary Page Only",!,"(3) BOTH"

 +3        KILL DIR

           SET DIR(0)="N^1:3"

           SET DIR("A")="Choose number"

 +4        DO ^DIR

           SET DGSUMPG=Y

           QUIT 

 +5       ;

SCRN      ;--include awaiting trans deficiency?

 +1        KILL DIR

           SET DIR(0)="Y"

           SET DIR("B")="NO"

 +2        SET DIR("A")="Include 'AWAITING TRANS' deficiencies"

 +3        DO ^DIR

           SET DGSCRN='Y

           QUIT 

 +4       ;

DEV       ;--device selection

 +1        SET %ZIS="PQ"

           DO ^%ZIS

           QUIT 

 +2       ;

QUE       ;--queued output     

 +1        KILL IO("Q")

           SET ZTRTN="EN^ADGDSIP"

           SET ZTDESC="PRINT CHART DEFICIENCY LIST"

 +2        NEW I

           FOR I="DGPR","DGDEL","DGNUM","DGSUMPG","DGSCRN","DGOPT","DGSCN"

               SET ZTSAVE(I)=""

 +3        DO ^%ZTLOAD

           DO ^%ZISC

           KILL ZTSK

           QUIT 

 +4       ;

EN        ;EP; --queued entry point

 +1        IF 'DGPR

               DO PA

           IF DGPR

               DO P1

           DO ^ADGDSIP1

           DO Q

           QUIT 

 +2       ;

PA        ;--all providers

 +1        FOR 

               SET DGPR=$ORDER(^ADGDSI("AC",DGPR))

               IF 'DGPR

                   QUIT 

               Begin DoDot:1

 +2                IF DGOPT=2

                       IF $PIECE($GET(^VA(200,+DGPR,"PS")),U,5)=DGSCN

                           DO P1

                       QUIT 

 +3                DO P1

               End DoDot:1

 +4        QUIT 

 +5       ;

P1        ;--one provider

 +1        NEW DFN,DS,PM

 +2        SET DFN=0

           FOR 

               SET DFN=$ORDER(^ADGDSI("AC",DGPR,DFN))

               IF 'DFN

                   QUIT 

               Begin DoDot:1

 +3                FOR DS=0:0

                       SET DS=$ORDER(^ADGDSI("AC",DGPR,DFN,DS))

                       IF 'DS

                           QUIT 

                       Begin DoDot:2

 +4                        IF DGOPT=1

                               IF $PIECE($GET(^ADGDSI(DFN,"DT",DS,0)),U,5)'=DGSCN

                                   QUIT 

 +5                        FOR PM=0:0

                               SET PM=$ORDER(^ADGDSI("AC",DGPR,DFN,DS,PM))

                               IF 'PM

                                   QUIT 

                               DO 1

                       End DoDot:2

               End DoDot:1

 +6        QUIT 

 +7       ;

1         ;

 +1        NEW NM,CHT,N,SUM,OPD,OPR,PRN,CD,DSD

 +2        SET NM=$PIECE($GET(^DPT(DFN,0)),U)

           SET CHT=$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)

 +3       ;discharge date ;date summary dictated ;date op report dictated

 +4        SET N=$GET(^ADGDSI(DFN,"DT",DS,0))

           IF N=""

               QUIT 

 +5        SET DSD=$PIECE(N,U)

           SET OPD=$PIECE(N,U,2)

           SET OPR=$PIECE(N,U,3)

 +6        SET PRN=$PIECE($GET(^VA(200,+DGPR,0)),U)

 +7       ;--chart deficiencies

 +8        NEW X,X1

           SET CD=""

           SET X=0

 +9        FOR 

               SET X=$ORDER(^ADGDSI(DFN,"DT",DS,"P",PM,"CD",X))

               IF 'X

                   QUIT 

               Begin DoDot:1

 +10               SET X1=$PIECE(^ADGDSI(DFN,"DT",DS,"P",PM,"CD",X,0),U)

 +11               IF DGSCRN

                       IF ^ADGCD(X1,0)["AWAITING TRANS"

                           QUIT 

 +12               SET CD=$SELECT(CD="":X1,1:CD_U_X1)

               End DoDot:1

 +13      ;--utility

 +14       IF CD=""

               QUIT 

           SET ^TMP("DGZICPL",$JOB,PRN,DSD,NM,DFN)=CHT_U_OPD_U_OPR_U_CD

           QUIT 

 +15      ;

Q         ;--cleanup

 +1        KILL DGPR,DIR,POP,DGFLG,DGDEL,DGSUMPG,DGSCRN,DGNUM,DGOPT,DGSCN

 +2        DO HOME^%ZIS

           QUIT