ADEFPC ; IHS/HQT/MJL - F COMPLIANCE PT 1 ;05:11 PM [ 03/24/1999 9:04 AM ]
;;6.0;ADE;;APRIL 1999
;
D ^XBKVAR I '$D(DUZ(2)) W !,"DIVISION NOT SET IN USER FILE -- CONTACT SITE MANAGER OR ISC" Q
I DUZ(2)=0 W !,"DIVISION SET TO ZERO (UNIVERSAL). DIVISION MUST BE SET TO ONE OF THE ",!,"SITES IN THE DENTAL SITE PARAMETER FILE. -- CONTACT SITE MANAGER" Q
;
PRE D ^ADECLS
S ADEXX="Compliance Summary By Water System"
W $J("",(80-$L(ADEXX))\2)_ADEXX,!,!
N ADEROPT
S ADECOMP=$S($D(^ADEPARAM(DUZ(2),0)):+$P(^ADEPARAM(DUZ(2),0),U,7),1:1) S:'ADECOMP ADECOMP=1
DATE ;GET DATE RANGE
S U="^",%DT="AE",%DT(0)=-DT,%DT("A")="SELECT BEGINNING MONTH-YEAR: " D ^%DT K %DT
G:Y<0 END S ADEBD=Y,%DT="AE",%DT(0)=ADEBD,%DT("A")="SELECT ENDING MONTH-YEAR: " D ^%DT K %DT
G:X="^" DATE G:Y<0 END S ADEED=Y I ADEED>DT W " ??",*7 G DATE
;
ROPT ;GET REPORT OPTIONS
W !
S ADEROPT=$$REP^ADEFPC4()
I $$HAT^ADEPQA() W ! G DATE
I ADEROPT="" W !!,"No reports selected." G END
W !!
I ADEROPT[1 W "AREA" W:$L(ADEROPT)>2 ", "
I ADEROPT[2 W:ADEROPT=12 " and " W "SERVICE UNIT"
I ADEROPT[3 W:$L(ADEROPT)>1 " and " W "WATER SYSTEM"
W " Report" W:$L(ADEROPT)>1 "s" W " will be printed.",!
;
S ADEU=$$ADEU()
K ^TMP("ADEFPC",ADEU)
;^TMP is a transient, non-fileman working global.
S ^TMP("ADEFPC",ADEU)="RUNNING"
;W !!,"JOB ",$J,": ADEU=",ADEU R !!,AZZ ;***COMMENT & KEEP
D ASKDEV
I POP K ^TMP("ADEFPC",ADEU) G END
;FHL 9/9/98 I $D(ZTSK) G END
I $D(ZTQUEUED) G END
;
ZTM ;EP TASKMAN ENTRY FOR PROCESSING PHASE
I $D(ZTQUEUED) L +^TMP("ADEFPC",ADEU):1 I '$T S ZTREQ="@" G END
S ADEJ=($E(ADEED,1,3)-$E(ADEBD,1,3)+1)*12-($E(ADEBD,4,5)-1)-($E(ADEED,1,3)_"12"-$E(ADEED,1,5))
S ^TMP("ADEFPC",ADEU)=ADEBD_U_ADEED_U_DT_U_ADEJ
S ADEWSDFN=0
F S ADEWSDFN=$O(^ADEWS(ADEWSDFN)) Q:'+ADEWSDFN D
. S ADEWSNOD=^ADEWS(ADEWSDFN,0)
. S ADEWSNAM=$P(ADEWSNOD,"^",2)_"-"_$P(ADEWSNOD,"^")
. I $P(ADEWSNOD,U,8)="y" Q
. S ADECOMM=$P(ADEWSNOD,"^",6) Q:ADECOMM']""
. S ADECOMM=^AUTTCOM(ADECOMM,0)
. S ADESU=$P(ADECOMM,"^",5) Q:ADESU']""
. S ADESU=^AUTTSU(ADESU,0)
. S ADESUNAM=$P(ADESU,U)
. S ADESU=$P(ADESU,U,4) Q:ADESU']""
. S ADEAREA=$P(ADECOMM,"^",6) Q:'ADEAREA
. S ADEAREA=^AUTTAREA(ADEAREA,0)
. S ADEARNAM=$P(ADEAREA,U)
. S ADEAREA=$P(ADEAREA,U,2) Q:ADEAREA']""
. Q:'$D(^ADEFLU("B",ADEWSDFN))
. S ADEFLDFN=$O(^ADEFLU("B",ADEWSDFN,0))
. D ^ADEFPC1
D PCOMP^ADEFPC3
I $O(^TMP("ADEFPC",ADEU,0))="" G END
;
I $D(ZTQUEUED) D G END
. I $D(IOT),IOT'="HFS" D Q
. . S ZTREQ=$H_U_ADEIOP_U_"FLUORIDE COMPLIANCE REPORT"_U_"PRINT^ADEFPC"
. D PRINT Q
I '$D(ZTQUEUED) D PRINT
;
;
END I $D(ADEU) L -^TMP("ADEFPC",ADEU)
K ADEABS,ADEABSMO,ADEBD,ADEBM,ADEBSU,ADECML,ADECOMM,ADECOMP,ADECPPM,ADECUR,ADEDEF,ADEED,ADEEM,ADEESU,ADEFLDFN,ADEINC
K ADEJ,ADEK,ADELAT,ADELIN,ADEMCNT,ADEMOCNT,ADEMPPM,ADENAT,ADENEX,ADENEXMO,ADEOPT,ADEPAG,ADEPOP,ADEQ,ADEQIT,ADESHORT,ADESL
K ADESTOP,ADESU,ADESUCNT,ADESYS,ADESYCNT,ADETCNT,ADETDAY,ADETPPM,ADETST,ADEWSDFN,ADEWSNAM,ADEWSNOD,ADEXX,ADEX,ADEYM
K ADEIOP,ADEU,ADEAREA,ADETMON,ADESUNAM,ADEARNAM,ADEMO
K ADED0,ADED1,ADED2,ADED3,ADEZTSK,ADEIOPAR
K ADENOD,ADEROPT
Q
;
PRINT ;EP TASKMAN ENTRY FOR PRINT PHASE
I '$D(^TMP("ADEFPC",ADEU)) G PRNEND
I '+$O(^TMP("ADEFPC",ADEU,0)) G PRNEND
I $D(ZTQUEUED) L +^TMP("ADEFPC",ADEU):1 I '$T S ADENOLOK=1 G PRNEND
N FLDS
F FLDS="[ADEP-ADEFPC-AREA]","[ADEP-ADEFPC-SU]","[ADEP-ADEFPC-SYS2]" D
. Q:FLDS["AREA"&(ADEROPT'["1")
. Q:FLDS["SU"&(ADEROPT'["2")
. Q:FLDS["SYS"&(ADEROPT'["3")
. N DIC,BY,ADED0,ADED1,ADED2,ADED3,DHD,Y
. S IOP=ADEIOP
. S %ZIS("IOPAR")=ADEIOPAR
. D ^%ZIS
. S IOP=ADEIOP
. S %ZIS("IOPAR")=ADEIOPAR
. S DIC="^ADEDUM(",BY="@NUMBER",(FR,TO)=""
. S ADED0=0,ADED1=0
. ;FHL 9/9/98 I $D(ZTSK) S ADEZTSK=ZTSK K ZTSK
. I $D(ZTQUEUED) S ADEZTSK=ZTSK K ZTSK
. D EN1^DIP
. I $D(ADEZTSK) S ZTSK=ADEZTSK
PRNEND I $D(ZTQUEUED) S ZTREQ="@"
I '$D(ADENOLOK) K ^TMP("ADEFPC",ADEU)
K ADENOLOK
Q
;
ASKDEV ;
K ADEIOP,IOP,ZTSK,ADEIOPAR
W !!,"Enter 'Q' at the DEVICE prompt to queue this report to run in the background."
S %ZIS="NQ"
D ^%ZIS
Q:POP
S ADEIOP=ION_";"_IOM_";"_IOSL
S ADEIOPAR=IOPAR
Q:'$D(IO("Q"))
D QUE
;FHL 9/9/98 I '$D(ZTSK) K IOP,ADEIOP G ASKDEV
I '$D(ZTQUEUED) K IOP,ADEIOP G ASKDEV
D HOME^%ZIS
W !,"REPORT IS QUEUED!"
Q
;
QUE ;
N ADEJ
S ZTRTN="ZTM^ADEFPC",ZTDESC="FLUORIDE REPORT PROCESSING"
F ADEJ="ADEIOP","ADEBD","ADEED","ADECOMP","ADEU" S ZTSAVE(ADEJ)=""
S ZTSAVE("ADEIOPAR")=""
S ZTSAVE("ADEROPT")=""
S ZTIO=""
I $D(IO("HFSIO")) D
. S ZTIO=ADEIOP
D ^%ZTLOAD
Q
;
ADEU() ;GET UNIQUE SUBSCRIPT NUMBER AND LOCK REPORT NODE
;RETURNS SUBSCRIPT NUMBER
S ADEU=$J
ADEU1 F L +^TMP("ADEFPC",ADEU):.1 Q:$T S ADEU=ADEU+1
I $G(^TMP("ADEFPC",ADEU))="RUNNING" L -^TMP("ADEFPC",ADEU) S ADEU=ADEU+1 G ADEU1
Q ADEU
ADEFPC ; IHS/HQT/MJL - F COMPLIANCE PT 1 ;05:11 PM [ 03/24/1999 9:04 AM ]
+1 ;;6.0;ADE;;APRIL 1999
+2 ;
+3 DO ^XBKVAR
IF '$DATA(DUZ(2))
WRITE !,"DIVISION NOT SET IN USER FILE -- CONTACT SITE MANAGER OR ISC"
QUIT
+4 IF DUZ(2)=0
WRITE !,"DIVISION SET TO ZERO (UNIVERSAL). DIVISION MUST BE SET TO ONE OF THE ",!,"SITES IN THE DENTAL SITE PARAMETER FILE. -- CONTACT SITE MANAGER"
QUIT
+5 ;
PRE DO ^ADECLS
+1 SET ADEXX="Compliance Summary By Water System"
+2 WRITE $JUSTIFY("",(80-$LENGTH(ADEXX))\2)_ADEXX,!,!
+3 NEW ADEROPT
+4 SET ADECOMP=$SELECT($DATA(^ADEPARAM(DUZ(2),0)):+$PIECE(^ADEPARAM(DUZ(2),0),U,7),1:1)
IF 'ADECOMP
SET ADECOMP=1
DATE ;GET DATE RANGE
+1 SET U="^"
SET %DT="AE"
SET %DT(0)=-DT
SET %DT("A")="SELECT BEGINNING MONTH-YEAR: "
DO ^%DT
KILL %DT
+2 IF Y<0
GOTO END
SET ADEBD=Y
SET %DT="AE"
SET %DT(0)=ADEBD
SET %DT("A")="SELECT ENDING MONTH-YEAR: "
DO ^%DT
KILL %DT
+3 IF X="^"
GOTO DATE
IF Y<0
GOTO END
SET ADEED=Y
IF ADEED>DT
WRITE " ??",*7
GOTO DATE
+4 ;
ROPT ;GET REPORT OPTIONS
+1 WRITE !
+2 SET ADEROPT=$$REP^ADEFPC4()
+3 IF $$HAT^ADEPQA()
WRITE !
GOTO DATE
+4 IF ADEROPT=""
WRITE !!,"No reports selected."
GOTO END
+5 WRITE !!
+6 IF ADEROPT[1
WRITE "AREA"
IF $LENGTH(ADEROPT)>2
WRITE ", "
+7 IF ADEROPT[2
IF ADEROPT=12
WRITE " and "
WRITE "SERVICE UNIT"
+8 IF ADEROPT[3
IF $LENGTH(ADEROPT)>1
WRITE " and "
WRITE "WATER SYSTEM"
+9 WRITE " Report"
IF $LENGTH(ADEROPT)>1
WRITE "s"
WRITE " will be printed.",!
+10 ;
+11 SET ADEU=$$ADEU()
+12 KILL ^TMP("ADEFPC",ADEU)
+13 ;^TMP is a transient, non-fileman working global.
+14 SET ^TMP("ADEFPC",ADEU)="RUNNING"
+15 ;W !!,"JOB ",$J,": ADEU=",ADEU R !!,AZZ ;***COMMENT & KEEP
+16 DO ASKDEV
+17 IF POP
KILL ^TMP("ADEFPC",ADEU)
GOTO END
+18 ;FHL 9/9/98 I $D(ZTSK) G END
+19 IF $DATA(ZTQUEUED)
GOTO END
+20 ;
ZTM ;EP TASKMAN ENTRY FOR PROCESSING PHASE
+1 IF $DATA(ZTQUEUED)
LOCK +^TMP("ADEFPC",ADEU):1
IF '$TEST
SET ZTREQ="@"
GOTO END
+2 SET ADEJ=($EXTRACT(ADEED,1,3)-$EXTRACT(ADEBD,1,3)+1)*12-($EXTRACT(ADEBD,4,5)-1)-($EXTRACT(ADEED,1,3)_"12"-$EXTRACT(ADEED,1,5))
+3 SET ^TMP("ADEFPC",ADEU)=ADEBD_U_ADEED_U_DT_U_ADEJ
+4 SET ADEWSDFN=0
+5 FOR
SET ADEWSDFN=$ORDER(^ADEWS(ADEWSDFN))
IF '+ADEWSDFN
QUIT
Begin DoDot:1
+6 SET ADEWSNOD=^ADEWS(ADEWSDFN,0)
+7 SET ADEWSNAM=$PIECE(ADEWSNOD,"^",2)_"-"_$PIECE(ADEWSNOD,"^")
+8 IF $PIECE(ADEWSNOD,U,8)="y"
QUIT
+9 SET ADECOMM=$PIECE(ADEWSNOD,"^",6)
IF ADECOMM']""
QUIT
+10 SET ADECOMM=^AUTTCOM(ADECOMM,0)
+11 SET ADESU=$PIECE(ADECOMM,"^",5)
IF ADESU']""
QUIT
+12 SET ADESU=^AUTTSU(ADESU,0)
+13 SET ADESUNAM=$PIECE(ADESU,U)
+14 SET ADESU=$PIECE(ADESU,U,4)
IF ADESU']""
QUIT
+15 SET ADEAREA=$PIECE(ADECOMM,"^",6)
IF 'ADEAREA
QUIT
+16 SET ADEAREA=^AUTTAREA(ADEAREA,0)
+17 SET ADEARNAM=$PIECE(ADEAREA,U)
+18 SET ADEAREA=$PIECE(ADEAREA,U,2)
IF ADEAREA']""
QUIT
+19 IF '$DATA(^ADEFLU("B",ADEWSDFN))
QUIT
+20 SET ADEFLDFN=$ORDER(^ADEFLU("B",ADEWSDFN,0))
+21 DO ^ADEFPC1
End DoDot:1
+22 DO PCOMP^ADEFPC3
+23 IF $ORDER(^TMP("ADEFPC",ADEU,0))=""
GOTO END
+24 ;
+25 IF $DATA(ZTQUEUED)
Begin DoDot:1
+26 IF $DATA(IOT)
IF IOT'="HFS"
Begin DoDot:2
+27 SET ZTREQ=$HOROLOG_U_ADEIOP_U_"FLUORIDE COMPLIANCE REPORT"_U_"PRINT^ADEFPC"
End DoDot:2
QUIT
+28 DO PRINT
QUIT
End DoDot:1
GOTO END
+29 IF '$DATA(ZTQUEUED)
DO PRINT
+30 ;
+31 ;
END IF $DATA(ADEU)
LOCK -^TMP("ADEFPC",ADEU)
+1 KILL ADEABS,ADEABSMO,ADEBD,ADEBM,ADEBSU,ADECML,ADECOMM,ADECOMP,ADECPPM,ADECUR,ADEDEF,ADEED,ADEEM,ADEESU,ADEFLDFN,ADEINC
+2 KILL ADEJ,ADEK,ADELAT,ADELIN,ADEMCNT,ADEMOCNT,ADEMPPM,ADENAT,ADENEX,ADENEXMO,ADEOPT,ADEPAG,ADEPOP,ADEQ,ADEQIT,ADESHORT,ADESL
+3 KILL ADESTOP,ADESU,ADESUCNT,ADESYS,ADESYCNT,ADETCNT,ADETDAY,ADETPPM,ADETST,ADEWSDFN,ADEWSNAM,ADEWSNOD,ADEXX,ADEX,ADEYM
+4 KILL ADEIOP,ADEU,ADEAREA,ADETMON,ADESUNAM,ADEARNAM,ADEMO
+5 KILL ADED0,ADED1,ADED2,ADED3,ADEZTSK,ADEIOPAR
+6 KILL ADENOD,ADEROPT
+7 QUIT
+8 ;
PRINT ;EP TASKMAN ENTRY FOR PRINT PHASE
+1 IF '$DATA(^TMP("ADEFPC",ADEU))
GOTO PRNEND
+2 IF '+$ORDER(^TMP("ADEFPC",ADEU,0))
GOTO PRNEND
+3 IF $DATA(ZTQUEUED)
LOCK +^TMP("ADEFPC",ADEU):1
IF '$TEST
SET ADENOLOK=1
GOTO PRNEND
+4 NEW FLDS
+5 FOR FLDS="[ADEP-ADEFPC-AREA]","[ADEP-ADEFPC-SU]","[ADEP-ADEFPC-SYS2]"
Begin DoDot:1
+6 IF FLDS["AREA"&(ADEROPT'["1")
QUIT
+7 IF FLDS["SU"&(ADEROPT'["2")
QUIT
+8 IF FLDS["SYS"&(ADEROPT'["3")
QUIT
+9 NEW DIC,BY,ADED0,ADED1,ADED2,ADED3,DHD,Y
+10 SET IOP=ADEIOP
+11 SET %ZIS("IOPAR")=ADEIOPAR
+12 DO ^%ZIS
+13 SET IOP=ADEIOP
+14 SET %ZIS("IOPAR")=ADEIOPAR
+15 SET DIC="^ADEDUM("
SET BY="@NUMBER"
SET (FR,TO)=""
+16 SET ADED0=0
SET ADED1=0
+17 ;FHL 9/9/98 I $D(ZTSK) S ADEZTSK=ZTSK K ZTSK
+18 IF $DATA(ZTQUEUED)
SET ADEZTSK=ZTSK
KILL ZTSK
+19 DO EN1^DIP
+20 IF $DATA(ADEZTSK)
SET ZTSK=ADEZTSK
End DoDot:1
PRNEND IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+1 IF '$DATA(ADENOLOK)
KILL ^TMP("ADEFPC",ADEU)
+2 KILL ADENOLOK
+3 QUIT
+4 ;
ASKDEV ;
+1 KILL ADEIOP,IOP,ZTSK,ADEIOPAR
+2 WRITE !!,"Enter 'Q' at the DEVICE prompt to queue this report to run in the background."
+3 SET %ZIS="NQ"
+4 DO ^%ZIS
+5 IF POP
QUIT
+6 SET ADEIOP=ION_";"_IOM_";"_IOSL
+7 SET ADEIOPAR=IOPAR
+8 IF '$DATA(IO("Q"))
QUIT
+9 DO QUE
+10 ;FHL 9/9/98 I '$D(ZTSK) K IOP,ADEIOP G ASKDEV
+11 IF '$DATA(ZTQUEUED)
KILL IOP,ADEIOP
GOTO ASKDEV
+12 DO HOME^%ZIS
+13 WRITE !,"REPORT IS QUEUED!"
+14 QUIT
+15 ;
QUE ;
+1 NEW ADEJ
+2 SET ZTRTN="ZTM^ADEFPC"
SET ZTDESC="FLUORIDE REPORT PROCESSING"
+3 FOR ADEJ="ADEIOP","ADEBD","ADEED","ADECOMP","ADEU"
SET ZTSAVE(ADEJ)=""
+4 SET ZTSAVE("ADEIOPAR")=""
+5 SET ZTSAVE("ADEROPT")=""
+6 SET ZTIO=""
+7 IF $DATA(IO("HFSIO"))
Begin DoDot:1
+8 SET ZTIO=ADEIOP
End DoDot:1
+9 DO ^%ZTLOAD
+10 QUIT
+11 ;
ADEU() ;GET UNIQUE SUBSCRIPT NUMBER AND LOCK REPORT NODE
+1 ;RETURNS SUBSCRIPT NUMBER
+2 SET ADEU=$JOB
ADEU1 FOR
LOCK +^TMP("ADEFPC",ADEU):.1
IF $TEST
QUIT
SET ADEU=ADEU+1
+1 IF $GET(^TMP("ADEFPC",ADEU))="RUNNING"
LOCK -^TMP("ADEFPC",ADEU)
SET ADEU=ADEU+1
GOTO ADEU1
+2 QUIT ADEU
