ADEKNT3 ; IHS/HQT/MJL - COMPILE DENTAL REPORTS ; [ 03/24/1999 9:04 AM ]
;;6.0;ADE;;APRIL 1999
FILE ;EP
;For each objective-agegroup in ^TMP($J,"CTR",
; Create unique entry by concatenating YEAR.QUARTER.OBJECTIVE.AGEGROUP
; Test whether an entry by that name already exists
; If not, create it
; Populate the entry with values from ^TMP($J,"CTR",
;
N ADENOD,ADEIEN,ADEGRP,ADE01
L +^ADEKNT:$S($D(DTIME):DTIME,1:300) Q:'$T
S ADEIEN=0
F S ADEIEN=$O(^TMP($J,"CTR",ADEIEN)) Q:'+ADEIEN D
. S ADEGRP=0
. F S ADEGRP=$O(^TMP($J,"CTR",ADEIEN,ADEGRP)) Q:ADEGRP'?1N.E D
. . D ENTRY(ADEIEN,ADEGRP,"")
. . S ADELOE=""
. . F S ADELOE=$O(^TMP($J,"CTR",ADEIEN,ADEGRP,ADELOE)) Q:'+ADELOE D
. . . D ENTRY(ADEIEN,ADEGRP,ADELOE)
. . . Q
. . Q
. Q
L -^ADEKNT:DTIME
Q
;
ENTRY(ADEIEN,ADEGRP,ADELOE) ;EP
N ADE01,ADENOD
S ADE01=$P(ADEPER,U)_"."_ADEIEN_"."_ADEGRP
I +ADELOE D
. S ADE01=ADE01_"."_ADELOE
. S ADENOD=^TMP($J,"CTR",ADEIEN,ADEGRP,ADELOE)
E S ADENOD=^TMP($J,"CTR",ADEIEN,ADEGRP)
I '$D(^ADEKNT("B",ADE01)) D
. S DIC="^ADEKNT("
. S DIC(0)="LZ"
. S X=ADE01
. K DD,DO
. D FILE^DICN
S DA=$O(^ADEKNT("B",ADE01,0))
;FHL 9/9/98 B:'+DA ;***remove after testing
S ADEYR=$P(ADE01,".")
;beginning Y2K fix
;S ADEYR=$S(ADEYR<81:20,1:19)_ADEYR ;OK, So I'm optimistic!
;end Y2K fix block
S DR=".02///"_$P(ADENOD,U)_";.03///"_$P(ADENOD,U,2)
S DR=DR_";.04///"_$P(ADENOD,U,3)_";.05///"_ADEYR
S DR=DR_";.06///"_$P(ADE01,".",2)_";.07///`"_ADEIEN
S DR=DR_";.09///"_$P(ADEGRP,":",2)
S:+ADELOE DR=DR_";.11///`"_ADELOE
S DR=DR_";.08///"_$P(ADEGRP,":")
S DIE="^ADEKNT("
D ^DIE
Q
;
BULL(ADEBUL) ;EP - Sends Bulletin
; ADEBUL=1 Complete
; ADEBUL=0 Abend
;
S XMB=$S(ADEBUL:"ADEK-COMPLETE",1:"ADEK-ABEND")
S XMDUZ="DENTAL PACKAGE"
S XMB(1)="UNKNOWN"
S:$D(ADEYQ) XMB(1)=+ADEYQ
I ADEBUL D
. S XMB(2)=$$MIN(ADE("STARTTIME"),$H)
. S XMB(2)=$S(+XMB(2):+XMB(2)_" Hours",1:"")_$S(+$P(XMB(2),U,2):$P(XMB(2),U,2)_" Minutes",1:"")
D ^XMB
Q
;
ERR ;EP - Error trap
;Log error info
I $D(^%ZOSF("ERRTN")) D @^%ZOSF("ERRTN")
;Send error bulletin
D BULL(0)
;go end
G END^ADEKNT
;
MIN(ADEX1,ADEX2) ;EP
;Returns number of HOURS^MINUTES between ADEX1 and ADEX2
;where ADEX1 < ADEX2 and both are in $H format
N ADEMIN
;
I $P(ADEX1,",")=$P(ADEX2,",") D
. S ADEMIN=$P(ADEX2,",",2)-$P(ADEX1,",",2)
;
E D
. S ADEMIN=86400-$P(ADEX1,",",2)
. S ADEMIN=ADEMIN+$P(ADEX2,",",2)
. S ADEMIN=ADEMIN+(86400*($P(ADEX2,",")-$P(ADEX1,",")-1))
;
S ADEMIN=$FN(ADEMIN/60,"",0)
S ADEMIN=(ADEMIN\60)_U_(ADEMIN#60)
Q ADEMIN
;
ADDMIN(ADENOW,ADEMIN) ;EP
;Returns $H value resulting from addition of
;ADEMIN minutes to ADENOW where ADENOW is a time
;in $H format.
;
N ADEH,ADEM,ADEP
S ADEMIN=ADEMIN*60
S ADEH=$P(ADENOW,",")
S ADEM=$P(ADENOW,",",2)
I (ADEM+ADEMIN)'>86400 Q ADEH_","_(ADEM+ADEMIN)
S ADEP=ADEM+ADEMIN
S ADEH=ADEH+(ADEP\86400)
S ADEM=(ADEP#86400)
Q ADEH_","_ADEM
ADEKNT3 ; IHS/HQT/MJL - COMPILE DENTAL REPORTS ; [ 03/24/1999 9:04 AM ]
+1 ;;6.0;ADE;;APRIL 1999
FILE ;EP
+1 ;For each objective-agegroup in ^TMP($J,"CTR",
+2 ; Create unique entry by concatenating YEAR.QUARTER.OBJECTIVE.AGEGROUP
+3 ; Test whether an entry by that name already exists
+4 ; If not, create it
+5 ; Populate the entry with values from ^TMP($J,"CTR",
+6 ;
+7 NEW ADENOD,ADEIEN,ADEGRP,ADE01
+8 LOCK +^ADEKNT:$SELECT($DATA(DTIME):DTIME,1:300)
IF '$TEST
QUIT
+9 SET ADEIEN=0
+10 FOR
SET ADEIEN=$ORDER(^TMP($JOB,"CTR",ADEIEN))
IF '+ADEIEN
QUIT
Begin DoDot:1
+11 SET ADEGRP=0
+12 FOR
SET ADEGRP=$ORDER(^TMP($JOB,"CTR",ADEIEN,ADEGRP))
IF ADEGRP'?1N.E
QUIT
Begin DoDot:2
+13 DO ENTRY(ADEIEN,ADEGRP,"")
+14 SET ADELOE=""
+15 FOR
SET ADELOE=$ORDER(^TMP($JOB,"CTR",ADEIEN,ADEGRP,ADELOE))
IF '+ADELOE
QUIT
Begin DoDot:3
+16 DO ENTRY(ADEIEN,ADEGRP,ADELOE)
+17 QUIT
End DoDot:3
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 LOCK -^ADEKNT:DTIME
+21 QUIT
+22 ;
ENTRY(ADEIEN,ADEGRP,ADELOE) ;EP
+1 NEW ADE01,ADENOD
+2 SET ADE01=$PIECE(ADEPER,U)_"."_ADEIEN_"."_ADEGRP
+3 IF +ADELOE
Begin DoDot:1
+4 SET ADE01=ADE01_"."_ADELOE
+5 SET ADENOD=^TMP($JOB,"CTR",ADEIEN,ADEGRP,ADELOE)
End DoDot:1
+6 IF '$TEST
SET ADENOD=^TMP($JOB,"CTR",ADEIEN,ADEGRP)
+7 IF '$DATA(^ADEKNT("B",ADE01))
Begin DoDot:1
+8 SET DIC="^ADEKNT("
+9 SET DIC(0)="LZ"
+10 SET X=ADE01
+11 KILL DD,DO
+12 DO FILE^DICN
End DoDot:1
+13 SET DA=$ORDER(^ADEKNT("B",ADE01,0))
+14 ;FHL 9/9/98 B:'+DA ;***remove after testing
+15 SET ADEYR=$PIECE(ADE01,".")
+16 ;beginning Y2K fix
+17 ;S ADEYR=$S(ADEYR<81:20,1:19)_ADEYR ;OK, So I'm optimistic!
+18 ;end Y2K fix block
+19 SET DR=".02///"_$PIECE(ADENOD,U)_";.03///"_$PIECE(ADENOD,U,2)
+20 SET DR=DR_";.04///"_$PIECE(ADENOD,U,3)_";.05///"_ADEYR
+21 SET DR=DR_";.06///"_$PIECE(ADE01,".",2)_";.07///`"_ADEIEN
+22 SET DR=DR_";.09///"_$PIECE(ADEGRP,":",2)
+23 IF +ADELOE
SET DR=DR_";.11///`"_ADELOE
+24 SET DR=DR_";.08///"_$PIECE(ADEGRP,":")
+25 SET DIE="^ADEKNT("
+26 DO ^DIE
+27 QUIT
+28 ;
BULL(ADEBUL) ;EP - Sends Bulletin
+1 ; ADEBUL=1 Complete
+2 ; ADEBUL=0 Abend
+3 ;
+4 SET XMB=$SELECT(ADEBUL:"ADEK-COMPLETE",1:"ADEK-ABEND")
+5 SET XMDUZ="DENTAL PACKAGE"
+6 SET XMB(1)="UNKNOWN"
+7 IF $DATA(ADEYQ)
SET XMB(1)=+ADEYQ
+8 IF ADEBUL
Begin DoDot:1
+9 SET XMB(2)=$$MIN(ADE("STARTTIME"),$HOROLOG)
+10 SET XMB(2)=$SELECT(+XMB(2):+XMB(2)_" Hours",1:"")_$SELECT(+$PIECE(XMB(2),U,2):$PIECE(XMB(2),U,2)_" Minutes",1:"")
End DoDot:1
+11 DO ^XMB
+12 QUIT
+13 ;
ERR ;EP - Error trap
+1 ;Log error info
+2 IF $DATA(^%ZOSF("ERRTN"))
DO @^%ZOSF("ERRTN")
+3 ;Send error bulletin
+4 DO BULL(0)
+5 ;go end
+6 GOTO END^ADEKNT
+7 ;
MIN(ADEX1,ADEX2) ;EP
+1 ;Returns number of HOURS^MINUTES between ADEX1 and ADEX2
+2 ;where ADEX1 < ADEX2 and both are in $H format
+3 NEW ADEMIN
+4 ;
+5 IF $PIECE(ADEX1,",")=$PIECE(ADEX2,",")
Begin DoDot:1
+6 SET ADEMIN=$PIECE(ADEX2,",",2)-$PIECE(ADEX1,",",2)
End DoDot:1
+7 ;
+8 IF '$TEST
Begin DoDot:1
+9 SET ADEMIN=86400-$PIECE(ADEX1,",",2)
+10 SET ADEMIN=ADEMIN+$PIECE(ADEX2,",",2)
+11 SET ADEMIN=ADEMIN+(86400*($PIECE(ADEX2,",")-$PIECE(ADEX1,",")-1))
End DoDot:1
+12 ;
+13 SET ADEMIN=$FNUMBER(ADEMIN/60,"",0)
+14 SET ADEMIN=(ADEMIN\60)_U_(ADEMIN#60)
+15 QUIT ADEMIN
+16 ;
ADDMIN(ADENOW,ADEMIN) ;EP
+1 ;Returns $H value resulting from addition of
+2 ;ADEMIN minutes to ADENOW where ADENOW is a time
+3 ;in $H format.
+4 ;
+5 NEW ADEH,ADEM,ADEP
+6 SET ADEMIN=ADEMIN*60
+7 SET ADEH=$PIECE(ADENOW,",")
+8 SET ADEM=$PIECE(ADENOW,",",2)
+9 IF (ADEM+ADEMIN)'>86400
QUIT ADEH_","_(ADEM+ADEMIN)
+10 SET ADEP=ADEM+ADEMIN
+11 SET ADEH=ADEH+(ADEP\86400)
+12 SET ADEM=(ADEP#86400)
+13 QUIT ADEH_","_ADEM
