ADEPQA ; IHS/HQT/MJL - QA ENGINE ;11:07 AM [ 03/24/1999 9:04 AM ]
;;6.0;ADE;;APRIL 1999
;
K ^ADEUTL("ADEPQA",$J),ADEEXT ;^ADEUTL is a transient working global
N ADEHXO,ADEHXC,ADESTP,ADEDATE,ADEAGE,ADEPROV,ADEHYG,ADELOC,ADEJ,ADEROPT,ADETFIL,ADETNAM,ADETDFN,ADEADA,BY,FLDS,FR,TO,DIC,DHD,ZTSK
CTRL D SEARCH G:$$HAT() END ;Set up Search parameters
CTRL1 D OUTPUT^ADEPQA1B G:$$HAT() CTRL ;Select Output Format & template
EN ;EP - Enter here with above predefined
D ASKDEV^ADEPQA1B I POP K POP G END
;FHL 9/9/98 I $D(ZTSK) G END
I $D(ZTQUEUED) G END
ZTM ;EP -
D ROLL ;$O through entries and screen accdng to criteria
I '$D(^DIBT(ADETDFN,1)) G END ;W !,"NO MATCHES" G END ;Improve msg
I '$D(ADEEXT) D PRINT ;Print Report
;
END Q:$D(ADEEXT) ;ADEEXT means it's an external call which is
; doing its own device handling
D ^%ZISC
I $D(ZTQUEUED) D
. D KILL^%ZTLOAD
. I $D(ADETNAM),ADETNAM?1"ADEQA"1.5N D DELTMP(ADETDFN)
I '$D(ZTQUEUED) D
. ;FHL 9/9/98 I '$D(ZTSK),$D(ADETNAM),ADETNAM?1"ADEQA"1.5N D DELTMP(ADETDFN)
. I '$D(ZTQUEUED),$D(ADETNAM),ADETNAM?1"ADEQA"1.5N D DELTMP(ADETDFN)
Q
;
PRINT ;
N ADEDUZ,ADEY
D EN1^DIP
Q
;
SEARCH ;
W !!,?5,"***STEP ONE: Select SEARCH PARAMETERS***"
S ADESTP=$$STP^ADEPQA3() Q:$$HAT()
SRCH1 S ADEDATE=$$DATE^ADEPQA3() G:$$HAT() SEARCH
SRCH2 S ADEAGE=$$AGE^ADEPQA3() G:$$HAT() SRCH1
SRCH3 S ADEPROV=$$PROV^ADEPQA3() G:$$HAT() SRCH2
SRCH4 S ADEHYG=$$HYG^ADEPQA3() G:$$HAT() SRCH3
SRCH5 S ADELOC=$$LOC^ADEPQA3() G:$$HAT() SRCH4
F ADEJ=1:1:1 S ADEADA(ADEJ)=$$ADA^ADEPQA3A()
G:$$HAT() SRCH5
I '$$CHK^ADEPQA4() G SEARCH ;Ask user to verify search params
Q
;
ROLL ;EP - At this point, all variables needed to do the report are defined
;This subrtn $O's through ADEPCD using the DATE xref (or the PRO
;VIDER xref if it's provider-limited but not date-limited)
;Hits are stored in the template.
N ADEHXC,ADEHXO
I +ADESTP,$P(ADESTP,U,3)="9002007" D Q
. N ADEDFN,ADESTD
. S ADESTD=$P(ADESTP,U,2)
. S ADEDFN=0
. F S ADEDFN=$O(^DIBT(ADESTD,1,ADEDFN)) Q:'+ADEDFN D SCREEN(ADEDFN)
I +ADESTP,$P(ADESTP,U,3)="9000001" D Q
. N ADEDFN,ADESTD,ADEBEG,ADEND,ADEPAT
. S ADESTD=$P(ADESTP,U,2)
. S ADEPAT=0
. S ADEND=$P(ADEDATE,U,3)
. F S ADEPAT=$O(^DIBT(ADESTD,1,ADEPAT)) Q:'+ADEPAT S ADEBEG=$P(ADEDATE,U,2)-1 D
. . F S ADEBEG=$O(^ADEPCD("DATE",ADEPAT,ADEBEG)) Q:'+ADEBEG Q:ADEBEG>ADEND S ADEDFN=0 D
. . . F S ADEDFN=$O(^ADEPCD("DATE",ADEPAT,ADEBEG,ADEDFN)) Q:'+ADEDFN D SCREEN(ADEDFN)
;
I +ADEDATE,$P(ADEROPT,U,2)'["PATIENT" D Q
. N ADEBEG,ADEND,ADEDFN
. S ADEBEG=$P(ADEDATE,U,2)-1,ADEND=$P(ADEDATE,U,3)
. F S ADEBEG=$O(^ADEPCD("AC",ADEBEG)) Q:ADEBEG>ADEND Q:'+ADEBEG S ADEDFN=0 D
. . F S ADEDFN=$O(^ADEPCD("AC",ADEBEG,ADEDFN)) Q:'ADEDFN D SCREEN(ADEDFN)
I +ADEDATE,$P(ADEROPT,U,2)["PATIENT" D Q
. N ADEBEG,ADEND,ADEDFN,ADEPAT
. S ADEPAT=0
. S ADEND=$P(ADEDATE,U,3)
. F S ADEPAT=$O(^ADEPCD("DATE",ADEPAT)) Q:'+ADEPAT S ADEBEG=$P(ADEDATE,U,2)-1 D
. . F S ADEBEG=$O(^ADEPCD("DATE",ADEPAT,ADEBEG)) Q:ADEBEG>ADEND Q:'+ADEBEG S ADEDFN=0 D
. . . F S ADEDFN=$O(^ADEPCD("DATE",ADEPAT,ADEBEG,ADEDFN)) Q:'+ADEDFN D SCREEN(ADEDFN)
Q
K ADESTD,ADETFIL,ADETNAM ;*NE
;------->SUB-SUBROUTINES
SCREEN(ADEDFN) ;
;Applies screens to ADEPCD entry ADEDFN
N ADENOD
S ADENOD=^ADEPCD(ADEDFN,0)
I +ADESTP,$P(ADESTP,U,3)="9002007",'$$DATSCN^ADEPQA1C(ADENOD) Q
I +ADEAGE,'$$AGESCN^ADEPQA1C(ADENOD) Q
I +ADELOC,'$$LOCSCN^ADEPQA1C(ADENOD) Q
I +ADEPROV,'$$PRVSCN^ADEPQA1C(ADENOD) Q
I +ADEHYG,'$$HYGSCN^ADEPQA1C(ADENOD) Q
I +ADEADA(1),'$$CODSCN^ADEPQA1D(ADEDFN) Q
D HIT(ADEDFN)
Q
HIT(ADEDFN) ;
;Adds ADEDFN to whatever template we're using
I $P(ADEROPT,U,2)="DENTAL" S ^DIBT(ADETDFN,1,ADEDFN)=""
E S ^DIBT(ADETDFN,1,$P(^ADEPCD(ADEDFN,0),U))=""
Q
;------->FUNCTIONS
HAT() ;EP
I $D(DTOUT)!($D(DUOUT))!($D(DIROUT)) Q 1
Q 0
;
TMPLAT(ADETNAM,ADETFIL) ;EP
;Creates entry in SORT TEMPLATE file attached to file # ADETFIL
;Returns template DFN
N DIC,X,DD,D0,Y,DR,DO
S DIC="^DIBT(",X=ADETNAM,DIC(0)="LZ",DIC("DR")="4///"_ADETFIL_";5///"_DUZ K DD,DO D FILE^DICN
Q +Y
;
;
DELTMP(ADETDFN) ;EP - Deletes template ADETDFN
N DR,DA,DIE
S DA=ADETDFN
S DR=".01///@",DIE="^DIBT("
D ^DIE
Q
ADEPQA ; IHS/HQT/MJL - QA ENGINE ;11:07 AM [ 03/24/1999 9:04 AM ]
+1 ;;6.0;ADE;;APRIL 1999
+2 ;
+3 ;^ADEUTL is a transient working global
KILL ^ADEUTL("ADEPQA",$JOB),ADEEXT
+4 NEW ADEHXO,ADEHXC,ADESTP,ADEDATE,ADEAGE,ADEPROV,ADEHYG,ADELOC,ADEJ,ADEROPT,ADETFIL,ADETNAM,ADETDFN,ADEADA,BY,FLDS,FR,TO,DIC,DHD,ZTSK
CTRL ;Set up Search parameters
DO SEARCH
IF $$HAT()
GOTO END
CTRL1 ;Select Output Format & template
DO OUTPUT^ADEPQA1B
IF $$HAT()
GOTO CTRL
EN ;EP - Enter here with above predefined
+1 DO ASKDEV^ADEPQA1B
IF POP
KILL POP
GOTO END
+2 ;FHL 9/9/98 I $D(ZTSK) G END
+3 IF $DATA(ZTQUEUED)
GOTO END
ZTM ;EP -
+1 ;$O through entries and screen accdng to criteria
DO ROLL
+2 ;W !,"NO MATCHES" G END ;Improve msg
IF '$DATA(^DIBT(ADETDFN,1))
GOTO END
+3 ;Print Report
IF '$DATA(ADEEXT)
DO PRINT
+4 ;
END ;ADEEXT means it's an external call which is
IF $DATA(ADEEXT)
QUIT
+1 ; doing its own device handling
+2 DO ^%ZISC
+3 IF $DATA(ZTQUEUED)
Begin DoDot:1
+4 DO KILL^%ZTLOAD
+5 IF $DATA(ADETNAM)
IF ADETNAM?1"ADEQA"1.5N
DO DELTMP(ADETDFN)
End DoDot:1
+6 IF '$DATA(ZTQUEUED)
Begin DoDot:1
+7 ;FHL 9/9/98 I '$D(ZTSK),$D(ADETNAM),ADETNAM?1"ADEQA"1.5N D DELTMP(ADETDFN)
+8 IF '$DATA(ZTQUEUED)
IF $DATA(ADETNAM)
IF ADETNAM?1"ADEQA"1.5N
DO DELTMP(ADETDFN)
End DoDot:1
+9 QUIT
+10 ;
PRINT ;
+1 NEW ADEDUZ,ADEY
+2 DO EN1^DIP
+3 QUIT
+4 ;
SEARCH ;
+1 WRITE !!,?5,"***STEP ONE: Select SEARCH PARAMETERS***"
+2 SET ADESTP=$$STP^ADEPQA3()
IF $$HAT()
QUIT
SRCH1 SET ADEDATE=$$DATE^ADEPQA3()
IF $$HAT()
GOTO SEARCH
SRCH2 SET ADEAGE=$$AGE^ADEPQA3()
IF $$HAT()
GOTO SRCH1
SRCH3 SET ADEPROV=$$PROV^ADEPQA3()
IF $$HAT()
GOTO SRCH2
SRCH4 SET ADEHYG=$$HYG^ADEPQA3()
IF $$HAT()
GOTO SRCH3
SRCH5 SET ADELOC=$$LOC^ADEPQA3()
IF $$HAT()
GOTO SRCH4
+1 FOR ADEJ=1:1:1
SET ADEADA(ADEJ)=$$ADA^ADEPQA3A()
+2 IF $$HAT()
GOTO SRCH5
+3 ;Ask user to verify search params
IF '$$CHK^ADEPQA4()
GOTO SEARCH
+4 QUIT
+5 ;
ROLL ;EP - At this point, all variables needed to do the report are defined
+1 ;This subrtn $O's through ADEPCD using the DATE xref (or the PRO
+2 ;VIDER xref if it's provider-limited but not date-limited)
+3 ;Hits are stored in the template.
+4 NEW ADEHXC,ADEHXO
+5 IF +ADESTP
IF $PIECE(ADESTP,U,3)="9002007"
Begin DoDot:1
+6 NEW ADEDFN,ADESTD
+7 SET ADESTD=$PIECE(ADESTP,U,2)
+8 SET ADEDFN=0
+9 FOR
SET ADEDFN=$ORDER(^DIBT(ADESTD,1,ADEDFN))
IF '+ADEDFN
QUIT
DO SCREEN(ADEDFN)
End DoDot:1
QUIT
+10 IF +ADESTP
IF $PIECE(ADESTP,U,3)="9000001"
Begin DoDot:1
+11 NEW ADEDFN,ADESTD,ADEBEG,ADEND,ADEPAT
+12 SET ADESTD=$PIECE(ADESTP,U,2)
+13 SET ADEPAT=0
+14 SET ADEND=$PIECE(ADEDATE,U,3)
+15 FOR
SET ADEPAT=$ORDER(^DIBT(ADESTD,1,ADEPAT))
IF '+ADEPAT
QUIT
SET ADEBEG=$PIECE(ADEDATE,U,2)-1
Begin DoDot:2
+16 FOR
SET ADEBEG=$ORDER(^ADEPCD("DATE",ADEPAT,ADEBEG))
IF '+ADEBEG
QUIT
IF ADEBEG>ADEND
QUIT
SET ADEDFN=0
Begin DoDot:3
+17 FOR
SET ADEDFN=$ORDER(^ADEPCD("DATE",ADEPAT,ADEBEG,ADEDFN))
IF '+ADEDFN
QUIT
DO SCREEN(ADEDFN)
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+18 ;
+19 IF +ADEDATE
IF $PIECE(ADEROPT,U,2)'["PATIENT"
Begin DoDot:1
+20 NEW ADEBEG,ADEND,ADEDFN
+21 SET ADEBEG=$PIECE(ADEDATE,U,2)-1
SET ADEND=$PIECE(ADEDATE,U,3)
+22 FOR
SET ADEBEG=$ORDER(^ADEPCD("AC",ADEBEG))
IF ADEBEG>ADEND
QUIT
IF '+ADEBEG
QUIT
SET ADEDFN=0
Begin DoDot:2
+23 FOR
SET ADEDFN=$ORDER(^ADEPCD("AC",ADEBEG,ADEDFN))
IF 'ADEDFN
QUIT
DO SCREEN(ADEDFN)
End DoDot:2
End DoDot:1
QUIT
+24 IF +ADEDATE
IF $PIECE(ADEROPT,U,2)["PATIENT"
Begin DoDot:1
+25 NEW ADEBEG,ADEND,ADEDFN,ADEPAT
+26 SET ADEPAT=0
+27 SET ADEND=$PIECE(ADEDATE,U,3)
+28 FOR
SET ADEPAT=$ORDER(^ADEPCD("DATE",ADEPAT))
IF '+ADEPAT
QUIT
SET ADEBEG=$PIECE(ADEDATE,U,2)-1
Begin DoDot:2
+29 FOR
SET ADEBEG=$ORDER(^ADEPCD("DATE",ADEPAT,ADEBEG))
IF ADEBEG>ADEND
QUIT
IF '+ADEBEG
QUIT
SET ADEDFN=0
Begin DoDot:3
+30 FOR
SET ADEDFN=$ORDER(^ADEPCD("DATE",ADEPAT,ADEBEG,ADEDFN))
IF '+ADEDFN
QUIT
DO SCREEN(ADEDFN)
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+31 QUIT
+32 ;*NE
KILL ADESTD,ADETFIL,ADETNAM
+33 ;------->SUB-SUBROUTINES
SCREEN(ADEDFN) ;
+1 ;Applies screens to ADEPCD entry ADEDFN
+2 NEW ADENOD
+3 SET ADENOD=^ADEPCD(ADEDFN,0)
+4 IF +ADESTP
IF $PIECE(ADESTP,U,3)="9002007"
IF '$$DATSCN^ADEPQA1C(ADENOD)
QUIT
+5 IF +ADEAGE
IF '$$AGESCN^ADEPQA1C(ADENOD)
QUIT
+6 IF +ADELOC
IF '$$LOCSCN^ADEPQA1C(ADENOD)
QUIT
+7 IF +ADEPROV
IF '$$PRVSCN^ADEPQA1C(ADENOD)
QUIT
+8 IF +ADEHYG
IF '$$HYGSCN^ADEPQA1C(ADENOD)
QUIT
+9 IF +ADEADA(1)
IF '$$CODSCN^ADEPQA1D(ADEDFN)
QUIT
+10 DO HIT(ADEDFN)
+11 QUIT
HIT(ADEDFN) ;
+1 ;Adds ADEDFN to whatever template we're using
+2 IF $PIECE(ADEROPT,U,2)="DENTAL"
SET ^DIBT(ADETDFN,1,ADEDFN)=""
+3 IF '$TEST
SET ^DIBT(ADETDFN,1,$PIECE(^ADEPCD(ADEDFN,0),U))=""
+4 QUIT
+5 ;------->FUNCTIONS
HAT() ;EP
+1 IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIROUT))
QUIT 1
+2 QUIT 0
+3 ;
TMPLAT(ADETNAM,ADETFIL) ;EP
+1 ;Creates entry in SORT TEMPLATE file attached to file # ADETFIL
+2 ;Returns template DFN
+3 NEW DIC,X,DD,D0,Y,DR,DO
+4 SET DIC="^DIBT("
SET X=ADETNAM
SET DIC(0)="LZ"
SET DIC("DR")="4///"_ADETFIL_";5///"_DUZ
KILL DD,DO
DO FILE^DICN
+5 QUIT +Y
+6 ;
+7 ;
DELTMP(ADETDFN) ;EP - Deletes template ADETDFN
+1 NEW DR,DA,DIE
+2 SET DA=ADETDFN
+3 SET DR=".01///@"
SET DIE="^DIBT("
+4 DO ^DIE
+5 QUIT
