ADEKSAV ; IHS/HQT/MJL - PRINT COMPILED REPORTS ; [ 03/24/1999 9:04 AM ]
;;6.0;ADE;;APRIL 1999
;
;THIS IS A SAVED VERSION OF ADEKRP FHL 9/9/98
;
N ADEYQ,ADEROPT,ADEU,ADEIOP
K DTOUT,DUOUT,DIRUT,DIROUT
;
;Get report period, options (SINGLE, COMBINED, QUARTERLY, ANN)
ASKYQ S ADEYQ=$$ASKYQ^ADEKRP3()
I 'ADEYQ D G END
. Q:ADEYQ'="NO DATA"
. W !,"There are no compiled dental statistics stored on this machine."
. W !,"If the compiled statistics routines were installed within the"
. W !,"past few hours, then the compiler routines are probably running"
. W !,"now and haven't finished compiling yet."
. W !,"Otherwise, you can start the compiling process manually by"
. W !,"Executing the ECMP option (Compile Dental Quarterly Statistics)"
. W !,"in the DEO submenu of the DENTAL SUPERVISOR's menu."
S ADEROPT=$$ROPT^ADEKRP3()
G:ADEROPT="" ASKYQ
;
;GET AND LOCK UNIQUE SUBSCRIPT FOR THE REPORT GLOBAL
S ADEU=$$ADEU^ADEPSUB()
K ^TMP("ADEP",ADEU) ;^TMP is a transient report global
S ^TMP("ADEP",ADEU)="RUNNING"
;
D ASKDEV^ADEKRP2("ZTM^ADEKRP","DENTAL OBJECTIVES REPORT PROCESSING")
I POP K ^TMP("ADEP",ADEU) G END
;FHL 9/9/98 I $D(ZTSK) G END
I $D(ZTQUEUED) G END
;
ZTM ;EP - TASKMAN PROCESSING PHASE
I $D(ZTQUEUED) L +^TMP("ADEP",ADEU):1 I '$T S ZTREQ="@" G END
N ADEREP,ADEDDS,ADEDATE,ADESER,ADEDNAM,ADEWK1,ADEWK2,ADEWK3,ADEH,DIR,ADEASD,ADEDEN,ADEMED,ADEYQT
;
;IENs in ^ADEKOB for Medical, Dental and Assessed objectives:
S ADEMED=".3.",ADEDEN=".6.",ADEASD=".8."
;
;OLD: ADEPER=Quarterly (1) or Annual (0)
;ADEPER="SQ","CQ","SA" OR "CA"
;for Single or Combined, Quarterly or Annual
I ADEROPT["SINGLE-QUARTER" D SINGLE^ADEKRP6("SQ",ADEYQ)
;Decrement ADEYQ by quarter, check for ADEKNT for that period
;if so, do single
I ADEROPT["COMBINE-QUARTER" D SINGLE^ADEKRP6("CQ",ADEYQ) D
. S ADEYQT=ADEYQ
. S ADEH=2
. F S ADEYQT=$$BACK(ADEYQT) Q:'$D(^ADEKNT("AD",ADEYQT_".3")) Q:ADEH>5 D SINGLE^ADEKRP6("CQ",ADEYQT) S ADEH=ADEH+1
I ADEROPT["SINGLE-YEAR" D SINGLE^ADEKRP6("SA",ADEYQ)
I ADEROPT["COMBINE-YEAR" D SINGLE^ADEKRP6("CA",ADEYQ)
I ADEROPT["ANNUAL DENTAL BASIC MEASURES" D CF^ADEKRP5("ANNUAL",ADEYQ) D
. S ADEYQT=ADEYQ
. F S ADEYQT=ADEYQT-1 Q:'$D(^ADEKNT("AD",ADEYQT_".3")) D CF^ADEKRP5("ANNUAL",ADEYQT)
I ADEROPT["QUARTERLY DENTAL BASIC MEASURES" D CF^ADEKRP5("QUARTERLY",ADEYQ) D
. S ADEYQT=ADEYQ
. S ADEH=2
. F S ADEYQT=$$BACK(ADEYQT) Q:'$D(^ADEKNT("AD",ADEYQT_".3")) Q:ADEH>5 D CF^ADEKRP5("QUARTERLY",ADEYQT) S ADEH=ADEH+1
;
;
;Q ;***Quit here to examine ^TMP array
G:$O(^TMP("ADEP",ADEU,0))="" END
;Call DIP to print array
I $D(ZTQUEUED) D G END
. I $D(IOT),IOT'="HFS" D Q
. . S ZTREQ=$H_U_ADEIOP_U_"DENTAL OBJECTIVES REPORT PRINTING"_U_"PRINT^ADEKRP1"
. D PRINT^ADEKRP1 Q
I '$D(ZTQUEUED) D PRINT^ADEKRP1
;
END K DUOUT,DTOUT,DIROUT,DIRUT
D END^ADEKRP2
Q
;
;
GETCNT(ADEYQ,ADEIEN,ADEAGEG) ;EP
;
;Returns "Quarter^Year^3-year" counts for
;Year.Quarter ADEYQ (YR.Q)
;objective entry ADEIEN (.N.)
;and age group ADEAGEG (YR:YR)
;Returns 0 if no entry for ADEYQ_ADEIEN
;
;If a specific entry in ADEKNT exists for the objective/age
;Returns values from that entry.
;Otherwise, starts with lower age and adds values
;of entries from ADEKNT thru upper range
;
AA N ADENOD,ADE01,ADELAG,ADEUAG,ADECNT,J
S ADE01=ADEYQ_ADEIEN_ADEAGEG
I $D(^ADEKNT("B",ADE01)) D Q ADE01
. S ADE01=$O(^ADEKNT("B",ADE01,0))
. S ADE01=^ADEKNT(ADE01,0)
. S ADE01=$P(ADE01,U,2,4)
S ADE01=$P(ADE01,".",1,3)
I '$D(^ADEKNT("AD",ADE01)) Q 0
S ADECNT="0^0^0"
S ADELAG=$P(ADEAGEG,":")-1
F S ADELAG=$O(^ADEKNT("AD",ADE01,ADELAG)) Q:ADELAG="" S ADENOD=$O(^ADEKNT("AD",ADE01,ADELAG,0)),ADEUAG=$P(^ADEKNT(ADENOD,0),U,9) Q:ADEUAG>$P(ADEAGEG,":",2) D
. S ADENOD=$P(^ADEKNT(ADENOD,0),U,2,4)
. F J=1:1:3 S $P(ADECNT,U,J)=$P(ADECNT,U,J)+$P(ADENOD,U,J)
ZZ Q ADECNT
;
BACK(ADEYQ) ;EP
;Returns YYYY.Q 1 quarter prior to ADEYQ
;
N ADEY,ADEQ
S ADEY=$P(ADEYQ,".")
;beginning Y2K fix
Q:$L(ADEY)<4 0 ;Y2000
;S:'ADEY ADEY=100
S ADEQ=+$P(ADEYQ,".",2)
S ADEQ=ADEQ-1
S:ADEQ=0 ADEQ=4,ADEY=ADEY-1 ;Y2000
;end Y2K fix block
Q ADEY_"."_ADEQ
ADEKSAV ; IHS/HQT/MJL - PRINT COMPILED REPORTS ; [ 03/24/1999 9:04 AM ]
+1 ;;6.0;ADE;;APRIL 1999
+2 ;
+3 ;THIS IS A SAVED VERSION OF ADEKRP FHL 9/9/98
+4 ;
+5 NEW ADEYQ,ADEROPT,ADEU,ADEIOP
+6 KILL DTOUT,DUOUT,DIRUT,DIROUT
+7 ;
+8 ;Get report period, options (SINGLE, COMBINED, QUARTERLY, ANN)
ASKYQ SET ADEYQ=$$ASKYQ^ADEKRP3()
+1 IF 'ADEYQ
Begin DoDot:1
+2 IF ADEYQ'="NO DATA"
QUIT
+3 WRITE !,"There are no compiled dental statistics stored on this machine."
+4 WRITE !,"If the compiled statistics routines were installed within the"
+5 WRITE !,"past few hours, then the compiler routines are probably running"
+6 WRITE !,"now and haven't finished compiling yet."
+7 WRITE !,"Otherwise, you can start the compiling process manually by"
+8 WRITE !,"Executing the ECMP option (Compile Dental Quarterly Statistics)"
+9 WRITE !,"in the DEO submenu of the DENTAL SUPERVISOR's menu."
End DoDot:1
GOTO END
+10 SET ADEROPT=$$ROPT^ADEKRP3()
+11 IF ADEROPT=""
GOTO ASKYQ
+12 ;
+13 ;GET AND LOCK UNIQUE SUBSCRIPT FOR THE REPORT GLOBAL
+14 SET ADEU=$$ADEU^ADEPSUB()
+15 ;^TMP is a transient report global
KILL ^TMP("ADEP",ADEU)
+16 SET ^TMP("ADEP",ADEU)="RUNNING"
+17 ;
+18 DO ASKDEV^ADEKRP2("ZTM^ADEKRP","DENTAL OBJECTIVES REPORT PROCESSING")
+19 IF POP
KILL ^TMP("ADEP",ADEU)
GOTO END
+20 ;FHL 9/9/98 I $D(ZTSK) G END
+21 IF $DATA(ZTQUEUED)
GOTO END
+22 ;
ZTM ;EP - TASKMAN PROCESSING PHASE
+1 IF $DATA(ZTQUEUED)
LOCK +^TMP("ADEP",ADEU):1
IF '$TEST
SET ZTREQ="@"
GOTO END
+2 NEW ADEREP,ADEDDS,ADEDATE,ADESER,ADEDNAM,ADEWK1,ADEWK2,ADEWK3,ADEH,DIR,ADEASD,ADEDEN,ADEMED,ADEYQT
+3 ;
+4 ;IENs in ^ADEKOB for Medical, Dental and Assessed objectives:
+5 SET ADEMED=".3."
SET ADEDEN=".6."
SET ADEASD=".8."
+6 ;
+7 ;OLD: ADEPER=Quarterly (1) or Annual (0)
+8 ;ADEPER="SQ","CQ","SA" OR "CA"
+9 ;for Single or Combined, Quarterly or Annual
+10 IF ADEROPT["SINGLE-QUARTER"
DO SINGLE^ADEKRP6("SQ",ADEYQ)
+11 ;Decrement ADEYQ by quarter, check for ADEKNT for that period
+12 ;if so, do single
+13 IF ADEROPT["COMBINE-QUARTER"
DO SINGLE^ADEKRP6("CQ",ADEYQ)
Begin DoDot:1
+14 SET ADEYQT=ADEYQ
+15 SET ADEH=2
+16 FOR
SET ADEYQT=$$BACK(ADEYQT)
IF '$DATA(^ADEKNT("AD",ADEYQT_".3"))
QUIT
IF ADEH>5
QUIT
DO SINGLE^ADEKRP6("CQ",ADEYQT)
SET ADEH=ADEH+1
End DoDot:1
+17 IF ADEROPT["SINGLE-YEAR"
DO SINGLE^ADEKRP6("SA",ADEYQ)
+18 IF ADEROPT["COMBINE-YEAR"
DO SINGLE^ADEKRP6("CA",ADEYQ)
+19 IF ADEROPT["ANNUAL DENTAL BASIC MEASURES"
DO CF^ADEKRP5("ANNUAL",ADEYQ)
Begin DoDot:1
+20 SET ADEYQT=ADEYQ
+21 FOR
SET ADEYQT=ADEYQT-1
IF '$DATA(^ADEKNT("AD",ADEYQT_".3"))
QUIT
DO CF^ADEKRP5("ANNUAL",ADEYQT)
End DoDot:1
+22 IF ADEROPT["QUARTERLY DENTAL BASIC MEASURES"
DO CF^ADEKRP5("QUARTERLY",ADEYQ)
Begin DoDot:1
+23 SET ADEYQT=ADEYQ
+24 SET ADEH=2
+25 FOR
SET ADEYQT=$$BACK(ADEYQT)
IF '$DATA(^ADEKNT("AD",ADEYQT_".3"))
QUIT
IF ADEH>5
QUIT
DO CF^ADEKRP5("QUARTERLY",ADEYQT)
SET ADEH=ADEH+1
End DoDot:1
+26 ;
+27 ;
+28 ;Q ;***Quit here to examine ^TMP array
+29 IF $ORDER(^TMP("ADEP",ADEU,0))=""
GOTO END
+30 ;Call DIP to print array
+31 IF $DATA(ZTQUEUED)
Begin DoDot:1
+32 IF $DATA(IOT)
IF IOT'="HFS"
Begin DoDot:2
+33 SET ZTREQ=$HOROLOG_U_ADEIOP_U_"DENTAL OBJECTIVES REPORT PRINTING"_U_"PRINT^ADEKRP1"
End DoDot:2
QUIT
+34 DO PRINT^ADEKRP1
QUIT
End DoDot:1
GOTO END
+35 IF '$DATA(ZTQUEUED)
DO PRINT^ADEKRP1
+36 ;
END KILL DUOUT,DTOUT,DIROUT,DIRUT
+1 DO END^ADEKRP2
+2 QUIT
+3 ;
+4 ;
GETCNT(ADEYQ,ADEIEN,ADEAGEG) ;EP
+1 ;
+2 ;Returns "Quarter^Year^3-year" counts for
+3 ;Year.Quarter ADEYQ (YR.Q)
+4 ;objective entry ADEIEN (.N.)
+5 ;and age group ADEAGEG (YR:YR)
+6 ;Returns 0 if no entry for ADEYQ_ADEIEN
+7 ;
+8 ;If a specific entry in ADEKNT exists for the objective/age
+9 ;Returns values from that entry.
+10 ;Otherwise, starts with lower age and adds values
+11 ;of entries from ADEKNT thru upper range
+12 ;
AA NEW ADENOD,ADE01,ADELAG,ADEUAG,ADECNT,J
+1 SET ADE01=ADEYQ_ADEIEN_ADEAGEG
+2 IF $DATA(^ADEKNT("B",ADE01))
Begin DoDot:1
+3 SET ADE01=$ORDER(^ADEKNT("B",ADE01,0))
+4 SET ADE01=^ADEKNT(ADE01,0)
+5 SET ADE01=$PIECE(ADE01,U,2,4)
End DoDot:1
QUIT ADE01
+6 SET ADE01=$PIECE(ADE01,".",1,3)
+7 IF '$DATA(^ADEKNT("AD",ADE01))
QUIT 0
+8 SET ADECNT="0^0^0"
+9 SET ADELAG=$PIECE(ADEAGEG,":")-1
+10 FOR
SET ADELAG=$ORDER(^ADEKNT("AD",ADE01,ADELAG))
IF ADELAG=""
QUIT
SET ADENOD=$ORDER(^ADEKNT("AD",ADE01,ADELAG,0))
SET ADEUAG=$PIECE(^ADEKNT(ADENOD,0),U,9)
IF ADEUAG>$PIECE(ADEAGEG,"
QUIT
Begin DoDot:1
+11 SET ADENOD=$PIECE(^ADEKNT(ADENOD,0),U,2,4)
+12 FOR J=1:1:3
SET $PIECE(ADECNT,U,J)=$PIECE(ADECNT,U,J)+$PIECE(ADENOD,U,J)
End DoDot:1
ZZ QUIT ADECNT
+1 ;
BACK(ADEYQ) ;EP
+1 ;Returns YYYY.Q 1 quarter prior to ADEYQ
+2 ;
+3 NEW ADEY,ADEQ
+4 SET ADEY=$PIECE(ADEYQ,".")
+5 ;beginning Y2K fix
+6 ;Y2000
IF $LENGTH(ADEY)<4
QUIT 0
+7 ;S:'ADEY ADEY=100
+8 SET ADEQ=+$PIECE(ADEYQ,".",2)
+9 SET ADEQ=ADEQ-1
+10 ;Y2000
IF ADEQ=0
SET ADEQ=4
SET ADEY=ADEY-1
+11 ;end Y2K fix block
+12 QUIT ADEY_"."_ADEQ
