ADGICPQ.m

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

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

 ;

 K ^TMP("DGZICPL",$J)

A ;--main

 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 ^ADGICPP,Q

 Q

 ;

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

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

 S X1=DT,X2=-$S(Z:Z,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(Z:Z,1:30)-Y D C^%DTC S DGDEL=X Q

 ;

HDH ;--intro

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

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

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

 W !?15,"will be considered delinquent!" Q

 ;

PROV ;--all providers or just one?

 I '$D(^XUSEC("DGZICPALL",DUZ)) D SELF Q

 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

 ;

SELF ; -- set user to only provider for report

 W !!,"I will print Incomplete/Delinquent Charts for "

 W $P($G(^VA(200,DUZ,0)),U),!!

 S DGPR=DUZ

 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^ADGICPQ",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 ;--queued entry point

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

 ;

PA ;--all providers

 F  S DGPR=$O(^ADGIC("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(^ADGIC("AC",DGPR,DFN)) Q:'DFN  D

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

 .. I DGOPT=1,$P($G(^ADGIC(DFN,"D",DS,0)),U,4)'=DGSCN Q

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

 Q

 ;

1 ;

 N NM,CHT,N,SUM,OP,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=^ADGIC(DFN,"D",DS,0),DSD=$P(N,U),SUM=$P(N,U,6),OP=$P(N,U,8)

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

 ;--chart deficiencies

 N X,X1 S CD="",X=0 F  S X=$O(^ADGIC(DFN,"D",DS,"P",PM,"C",X)) Q:'X  D

 . S X1=$P(^ADGIC(DFN,"D",DS,"P",PM,"C",X,0),U)

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

 . ;Q:^ADGCD(X1,0)["CODED A SHEET"

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

 ;--utility

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

 ;

Q ;--cleanup

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

 D HOME^%ZIS Q

ADGICPQ   ; IHS/ADC/PDW/ENM - CHART DEFICIENCY LIST 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        DO DELDT

           DO HDH

           DO PROV

           IF $DATA(DIRUT)

               DO Q

               QUIT 

 +2        DO COPY

           IF $DATA(DIRUT)

               DO Q

               QUIT 

 +3        DO SUMM

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

               DO Q

               QUIT 

 +4        DO SCRN

           IF $DATA(DIRUT)

               DO Q

               QUIT 

 +5        DO DEV

           IF POP

               DO Q

               QUIT 

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

               DO QUE

               DO Q

               QUIT 

 +7        IF 'DGPR

               DO PA

           IF DGPR

               DO P1

           DO ^ADGICPP

           DO Q

 +8        QUIT 

 +9       ;

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

 +1        NEW X,Y,Z,X1,X2

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

 +2        SET X1=DT

           SET X2=-$SELECT(Z:Z,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(Z:Z,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 discharge 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!"

           QUIT 

 +5       ;

PROV      ;--all providers or just one?

 +1        IF '$DATA(^XUSEC("DGZICPALL",DUZ))

               DO SELF

               QUIT 

 +2        KILL DIR

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

           SET DIR(0)="Y"

           SET DIR("B")="YES"

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

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

           SET DIR("?")=" "

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

           DO ^DIR

           IF Y

               QUIT 

           IF $DATA(DIRUT)

               QUIT 

 +6       ;--select option

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

 +8        KILL DIR

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

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

 +9        DO ^DIR

           SET DGOPT=+Y

           IF $DATA(DIRUT)

               QUIT 

 +10      ;--class

 +11       IF DGOPT=2

               Begin DoDot:1

 +12               KILL DIR

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

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

 +13               DO ^DIR

                   SET DGSCN=+Y

               End DoDot:1

               QUIT 

 +14      ;--specialty

 +15       IF DGOPT=1

               Begin DoDot:1

 +16               KILL DIR

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

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

 +17               DO ^DIR

                   SET DGSCN=+Y

               End DoDot:1

               QUIT 

 +18      ;--select provider

 +19       KILL DIC

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

           SET DIC=200

           SET DIC(0)="AEQZM"

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

 +21       DO ^DIC

           SET DGPR=+Y

           QUIT 

 +22      ;

SELF      ; -- set user to only provider for report

 +1        WRITE !!,"I will print Incomplete/Delinquent Charts for "

 +2        WRITE $PIECE($GET(^VA(200,DUZ,0)),U),!!

 +3        SET DGPR=DUZ

 +4        QUIT 

 +5       ;

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^ADGICPQ"

           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        ;--queued entry point

 +1        IF 'DGPR

               DO PA

           IF DGPR

               DO P1

           DO ^ADGICPP

           DO Q

           QUIT 

 +2       ;

PA        ;--all providers

 +1        FOR 

               SET DGPR=$ORDER(^ADGIC("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(^ADGIC("AC",DGPR,DFN))

               IF 'DFN

                   QUIT 

               Begin DoDot:1

 +3                FOR DS=0:0

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

                       IF 'DS

                           QUIT 

                       Begin DoDot:2

 +4                        IF DGOPT=1

                               IF $PIECE($GET(^ADGIC(DFN,"D",DS,0)),U,4)'=DGSCN

                                   QUIT 

 +5                        FOR PM=0:0

                               SET PM=$ORDER(^ADGIC("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,OP,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=^ADGIC(DFN,"D",DS,0)

           SET DSD=$PIECE(N,U)

           SET SUM=$PIECE(N,U,6)

           SET OP=$PIECE(N,U,8)

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

 +6       ;--chart deficiencies

 +7        NEW X,X1

           SET CD=""

           SET X=0

           FOR 

               SET X=$ORDER(^ADGIC(DFN,"D",DS,"P",PM,"C",X))

               IF 'X

                   QUIT 

               Begin DoDot:1

 +8                SET X1=$PIECE(^ADGIC(DFN,"D",DS,"P",PM,"C",X,0),U)

 +9                IF DGSCRN

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

                           QUIT 

 +10      ;Q:^ADGCD(X1,0)["CODED A SHEET"

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

               End DoDot:1

 +12      ;--utility

 +13       IF CD=""

               QUIT 

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

           QUIT 

 +14      ;

Q         ;--cleanup

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

 +2        DO HOME^%ZIS

           QUIT