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
