BHSDEN1 ;IHS/CIA/MGH - Health Summary for Dental ;17-Mar-2006 10:36;MGH
;;1.0;HEALTH SUMMARY COMPONENTS;;March 17, 2006
;===================================================================
;Taken from ADERVW1
; IHS/HQT/MJL - DENTAL CHART REVIEW PT 3 ; [ 03/24/1999 9:04 AM ]
;;6.0;ADE;;APRIL 1999
;Dental health summary; list procedures - continuation of BHSDEN
;
DO ; EP
I '$D(^ADEPCD("DATE",ADEPAT)) S ADETXT="<No Services on Record>",ADENRQ="",ADEICL=0 X ADEPRT Q
S ADETXT="SERVICES PROVIDED: ",ADENRQ="",ADEICL=20 X ADEPRT
K ^ADEUTL("DENTAA",$J)
S ADEDAT=(9999999-GMTSDLM)-1
F ADEQ=0:0 S ADEDAT=$O(^ADEPCD("DATE",ADEPAT,ADEDAT)) Q:'ADEDAT S ADEDFN="" F ADEQ=0:0 S ADEDFN=$O(^ADEPCD("DATE",ADEPAT,ADEDAT,ADEDFN)) Q:'ADEDFN S ^ADEUTL("DENTAA",$J,ADEPAT,9999999-(ADEDAT\1),ADEDFN)=""
S ADENDMS=ADENDM
S ADEDAT="" F ADEQ=0:0 S ADEDAT=$O(^ADEUTL("DENTAA",$J,ADEPAT,ADEDAT)) Q:ADEDAT=""!(ADEDAT>GMTSDLM)!(ADENDMS<1) S X=-ADEDAT+9999999 D REGDT4^GMTSU S ADEDTD=X S ADEDTU=0 D ONEDATE Q:$D(GMTSQIT) S ADENDMS=ADENDMS-1
DENTALX K ADEDAT,ADEDAT,ADEDTU,ADEDTD,ADEDFN,ADEY,ADEX,ADEDFN,ADESVD,ADEFO,ADESFN,ADEADA,ADEOP,ADENDN
K ADENSH,ADESITE
K ADETXT,ADENRQ,ADEICL
Q
ONEDATE S ADEDFN="" F ADEQ=0:0 S ADEDFN=$O(^ADEUTL("DENTAA",$J,ADEPAT,ADEDAT,ADEDFN)) Q:ADEDFN="" D DNTCHK Q:$D(GMTSQIT) D NARR Q:$D(GMTSQIT)
Q
DNTCHK ;
S ADESITE="" S ADESITE=$P(^ADEPCD(ADEDFN,0),U,3),ADEREP=$P(^(0),U,4),ADEPRV=$P(^(0),U,5),ADENOT=$P(^(0),U,7) X ADESITX
D CKP^GMTSUP Q:$D(GMTSQIT) S:GMTSNPG ADEDTU=0
I 'ADEDTU W ADEDTD S ADEFO=""
I ADENSH=ADEFO S ADESFN=""
E S (ADESFN,ADEFO)=ADENSH W ?10,ADESFN
I ADEREP]"",$D(^DIC(16,ADEREP,0)) W " --",$P(^DIC(16,ADEREP,0),U),"--"
I ADEPRV]"",ADEPRV'=ADEREP,$D(^DIC(16,ADEPRV,0)) W " (Provider: ",$P(^DIC(16,ADEPRV,0),U),")"
W !
S ADEDTU=1
D DSVC
I $D(ADENFLG) S ADETXT="*=Not reportable",ADEICL=4,ADENRQ="" X ADEPRT K ADENFLG
D NOTE
Q
;
NOTE ;DENTAL NOTE
Q:ADENOT=""
D CKP^GMTSUP Q:$D(GMTSQIT) W:GMTSNPG !,ADEDTD,?10,ADESFN," (Cont'd)",!
S ADENOT="NOTE: "_ADENOT
I $L(ADENOT)>70 S ADETXT=$E(ADENOT,1,70),ADEICL=4,ADENRQ="" X ADEPRT S ADETXT=$E(ADENOT,71,99),ADEICL=10,ADENRQ="" X ADEPRT Q
S ADETXT=ADENOT,ADEICL=4,ADENRQ="" X ADEPRT
Q
NARR ;DENTAL NARRATIVE
Q:'$D(^ADEPCD(ADEDFN,"NAR",0))
S ADETXT="",ADEX=0 F ADEQ=0:0 S ADEX=$O(^ADEPCD(ADEDFN,"NAR",ADEX)) Q:'ADEX S ADEY=^(ADEX,0) D NARR1
I ADETXT'="" S ADENRQ="",ADEICL=25 X ADEPRT
W !
Q
NARR1 ;CHECK TEXT LENGTH, IF > 241, PRINT TEXT
I $L(ADETXT_ADEY)<241 S ADETXT=ADETXT_" "_ADEY
E S ADENRQ="",ADEICL=25 X ADEPRT S ADETXT=ADEY
Q
DSVC D CKP^GMTSUP Q:$D(GMTSQIT) W:GMTSNPG !,ADEDTD,?10,ADESFN," (Cont'd)",!
D MOD0
D LINE
Q
MOD0 N ADENONR,ADEZ,ADEJ
S ADEJ=0,ADEOP="" K ADEV,ADEDES
MOD1 S ADEJ=$O(^ADEPCD(ADEDFN,"ADA","B",ADEJ)) I ADEJ="" K ADECNT,ADEK,ADEOP Q
G:'$D(^AUTTADA(ADEJ)) MOD1
S (ADECNT,ADEK)=0,ADEOP="",ADESFC="",ADENONR=""
MOD2 S ADEK=$O(^ADEPCD(ADEDFN,"ADA","B",ADEJ,ADEK))
I ADEK="" S ADEK=$P(^AUTTADA(ADEJ,0),U),ADEV(ADEK)=ADECNT_U_ADEOP_U_U_ADESFC_U_ADENONR,ADEDES(ADEK)=$P(^AUTTADA(ADEJ,0),U,6) G MOD1
S ADECNT=ADECNT+1
S X=$P(^ADEPCD(ADEDFN,"ADA",ADEK,0),U,2),ADEY=$P(^(0),U,4),ADEZ=$P(^(0),U,5) S:ADEZ["y" ADENFLG=1 I X="" S ADENONR=ADEZ G MOD2
G:'$D(^ADEOPS(X,88)) MOD2 S ADEPC=^ADEOPS(X,88),$P(ADEOP,",",ADECNT)=ADEPC,$P(ADESFC,",",ADECNT)=ADEY,$P(ADENONR,",",ADECNT)=ADEZ G MOD2
;
LINE N ADEJ,ADEFLG,ADEK,ADEPC,ADECNT
S ADEJ=0,ADEFLG=0
L1 S ADEJ=$O(ADEV(ADEJ)),ADEFLG=0 G:ADEJ="" L2
D CKP^GMTSUP Q:$D(GMTSQIT) W:GMTSNPG !,ADEDTD,?10,ADESFN," (Cont'd)",!
S ADETXT=ADEJ
I $P(ADEV(ADEJ),U,5)="y",$P(ADEV(ADEJ),U,2)="" S ADETXT=ADETXT_"* "
E S ADETXT=ADETXT_" "
S ADETXT=ADETXT_"("_$J($P(ADEV(ADEJ),U),2)_")"_" "_$E(ADEDES(ADEJ)_" ",1,20)
S ADECNT=0 F ADEK=1:1:$L($P(ADEV(ADEJ),U,2),",") D
. S ADEPC=$P($P(ADEV(ADEJ),U,2),",",ADEK)
. S ADEPC=ADEPC_$S($P($P(ADEV(ADEJ),U,4),",",ADEK)]"":"["_$P($P(ADEV(ADEJ),U,4),",",ADEK)_"]",1:"")
. S ADEPC=ADEPC_$S(($P($P(ADEV(ADEJ),U,5),",",ADEK)]"")&($P(ADEV(ADEJ),U,2)'=""):"*",1:"")
. S ADECNT=$L(ADEPC)+ADECNT+1
. D L3
S ADEICL=$S(ADEFLG:35,1:4),ADENRQ="" X ADEPRT
G L1
L2 K ADEJ Q
L3 I ADECNT>30 S ADECNT=0,ADETXT=ADETXT_" "_ADEPC,ADEICL=$S(ADEFLG:35,1:4),ADENRQ="" X ADEPRT S ADETXT="",ADEFLG=1 Q
S ADETXT=ADETXT_" "_ADEPC Q
BHSDEN1 ;IHS/CIA/MGH - Health Summary for Dental ;17-Mar-2006 10:36;MGH
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;;March 17, 2006
+2 ;===================================================================
+3 ;Taken from ADERVW1
+4 ; IHS/HQT/MJL - DENTAL CHART REVIEW PT 3 ; [ 03/24/1999 9:04 AM ]
+5 ;;6.0;ADE;;APRIL 1999
+6 ;Dental health summary; list procedures - continuation of BHSDEN
+7 ;
DO ; EP
+1 IF '$DATA(^ADEPCD("DATE",ADEPAT))
SET ADETXT="<No Services on Record>"
SET ADENRQ=""
SET ADEICL=0
XECUTE ADEPRT
QUIT
+2 SET ADETXT="SERVICES PROVIDED: "
SET ADENRQ=""
SET ADEICL=20
XECUTE ADEPRT
+3 KILL ^ADEUTL("DENTAA",$JOB)
+4 SET ADEDAT=(9999999-GMTSDLM)-1
+5 FOR ADEQ=0:0
SET ADEDAT=$ORDER(^ADEPCD("DATE",ADEPAT,ADEDAT))
IF 'ADEDAT
QUIT
SET ADEDFN=""
FOR ADEQ=0:0
SET ADEDFN=$ORDER(^ADEPCD("DATE",ADEPAT,ADEDAT,ADEDFN))
IF 'ADEDFN
QUIT
SET ^ADEUTL("DENTAA",$JOB,ADEPAT,9999999-(ADEDAT\1),ADEDFN)=""
+6 SET ADENDMS=ADENDM
+7 SET ADEDAT=""
FOR ADEQ=0:0
SET ADEDAT=$ORDER(^ADEUTL("DENTAA",$JOB,ADEPAT,ADEDAT))
IF ADEDAT=""!(ADEDAT>GMTSDLM)!(ADENDMS<1)
QUIT
SET X=-ADEDAT+9999999
DO REGDT4^GMTSU
SET ADEDTD=X
SET ADEDTU=0
DO ONEDATE
IF $DATA(GMTSQIT)
QUIT
SET ADENDMS=ADENDMS-1
DENTALX KILL ADEDAT,ADEDAT,ADEDTU,ADEDTD,ADEDFN,ADEY,ADEX,ADEDFN,ADESVD,ADEFO,ADESFN,ADEADA,ADEOP,ADENDN
+1 KILL ADENSH,ADESITE
+2 KILL ADETXT,ADENRQ,ADEICL
+3 QUIT
ONEDATE SET ADEDFN=""
FOR ADEQ=0:0
SET ADEDFN=$ORDER(^ADEUTL("DENTAA",$JOB,ADEPAT,ADEDAT,ADEDFN))
IF ADEDFN=""
QUIT
DO DNTCHK
IF $DATA(GMTSQIT)
QUIT
DO NARR
IF $DATA(GMTSQIT)
QUIT
+1 QUIT
DNTCHK ;
+1 SET ADESITE=""
SET ADESITE=$PIECE(^ADEPCD(ADEDFN,0),U,3)
SET ADEREP=$PIECE(^(0),U,4)
SET ADEPRV=$PIECE(^(0),U,5)
SET ADENOT=$PIECE(^(0),U,7)
XECUTE ADESITX
+2 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
SET ADEDTU=0
+3 IF 'ADEDTU
WRITE ADEDTD
SET ADEFO=""
+4 IF ADENSH=ADEFO
SET ADESFN=""
+5 IF '$TEST
SET (ADESFN,ADEFO)=ADENSH
WRITE ?10,ADESFN
+6 IF ADEREP]""
IF $DATA(^DIC(16,ADEREP,0))
WRITE " --",$PIECE(^DIC(16,ADEREP,0),U),"--"
+7 IF ADEPRV]""
IF ADEPRV'=ADEREP
IF $DATA(^DIC(16,ADEPRV,0))
WRITE " (Provider: ",$PIECE(^DIC(16,ADEPRV,0),U),")"
+8 WRITE !
+9 SET ADEDTU=1
+10 DO DSVC
+11 IF $DATA(ADENFLG)
SET ADETXT="*=Not reportable"
SET ADEICL=4
SET ADENRQ=""
XECUTE ADEPRT
KILL ADENFLG
+12 DO NOTE
+13 QUIT
+14 ;
NOTE ;DENTAL NOTE
+1 IF ADENOT=""
QUIT
+2 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
WRITE !,ADEDTD,?10,ADESFN," (Cont'd)",!
+3 SET ADENOT="NOTE: "_ADENOT
+4 IF $LENGTH(ADENOT)>70
SET ADETXT=$EXTRACT(ADENOT,1,70)
SET ADEICL=4
SET ADENRQ=""
XECUTE ADEPRT
SET ADETXT=$EXTRACT(ADENOT,71,99)
SET ADEICL=10
SET ADENRQ=""
XECUTE ADEPRT
QUIT
+5 SET ADETXT=ADENOT
SET ADEICL=4
SET ADENRQ=""
XECUTE ADEPRT
+6 QUIT
NARR ;DENTAL NARRATIVE
+1 IF '$DATA(^ADEPCD(ADEDFN,"NAR",0))
QUIT
+2 SET ADETXT=""
SET ADEX=0
FOR ADEQ=0:0
SET ADEX=$ORDER(^ADEPCD(ADEDFN,"NAR",ADEX))
IF 'ADEX
QUIT
SET ADEY=^(ADEX,0)
DO NARR1
+3 IF ADETXT'=""
SET ADENRQ=""
SET ADEICL=25
XECUTE ADEPRT
+4 WRITE !
+5 QUIT
NARR1 ;CHECK TEXT LENGTH, IF > 241, PRINT TEXT
+1 IF $LENGTH(ADETXT_ADEY)<241
SET ADETXT=ADETXT_" "_ADEY
+2 IF '$TEST
SET ADENRQ=""
SET ADEICL=25
XECUTE ADEPRT
SET ADETXT=ADEY
+3 QUIT
DSVC DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
WRITE !,ADEDTD,?10,ADESFN," (Cont'd)",!
+1 DO MOD0
+2 DO LINE
+3 QUIT
MOD0 NEW ADENONR,ADEZ,ADEJ
+1 SET ADEJ=0
SET ADEOP=""
KILL ADEV,ADEDES
MOD1 SET ADEJ=$ORDER(^ADEPCD(ADEDFN,"ADA","B",ADEJ))
IF ADEJ=""
KILL ADECNT,ADEK,ADEOP
QUIT
+1 IF '$DATA(^AUTTADA(ADEJ))
GOTO MOD1
+2 SET (ADECNT,ADEK)=0
SET ADEOP=""
SET ADESFC=""
SET ADENONR=""
MOD2 SET ADEK=$ORDER(^ADEPCD(ADEDFN,"ADA","B",ADEJ,ADEK))
+1 IF ADEK=""
SET ADEK=$PIECE(^AUTTADA(ADEJ,0),U)
SET ADEV(ADEK)=ADECNT_U_ADEOP_U_U_ADESFC_U_ADENONR
SET ADEDES(ADEK)=$PIECE(^AUTTADA(ADEJ,0),U,6)
GOTO MOD1
+2 SET ADECNT=ADECNT+1
+3 SET X=$PIECE(^ADEPCD(ADEDFN,"ADA",ADEK,0),U,2)
SET ADEY=$PIECE(^(0),U,4)
SET ADEZ=$PIECE(^(0),U,5)
IF ADEZ["y"
SET ADENFLG=1
IF X=""
SET ADENONR=ADEZ
GOTO MOD2
+4 IF '$DATA(^ADEOPS(X,88))
GOTO MOD2
SET ADEPC=^ADEOPS(X,88)
SET $PIECE(ADEOP,",",ADECNT)=ADEPC
SET $PIECE(ADESFC,",",ADECNT)=ADEY
SET $PIECE(ADENONR,",",ADECNT)=ADEZ
GOTO MOD2
+5 ;
LINE NEW ADEJ,ADEFLG,ADEK,ADEPC,ADECNT
+1 SET ADEJ=0
SET ADEFLG=0
L1 SET ADEJ=$ORDER(ADEV(ADEJ))
SET ADEFLG=0
IF ADEJ=""
GOTO L2
+1 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
WRITE !,ADEDTD,?10,ADESFN," (Cont'd)",!
+2 SET ADETXT=ADEJ
+3 IF $PIECE(ADEV(ADEJ),U,5)="y"
IF $PIECE(ADEV(ADEJ),U,2)=""
SET ADETXT=ADETXT_"* "
+4 IF '$TEST
SET ADETXT=ADETXT_" "
+5 SET ADETXT=ADETXT_"("_$JUSTIFY($PIECE(ADEV(ADEJ),U),2)_")"_" "_$EXTRACT(ADEDES(ADEJ)_" ",1,20)
+6 SET ADECNT=0
FOR ADEK=1:1:$LENGTH($PIECE(ADEV(ADEJ),U,2),",")
Begin DoDot:1
+7 SET ADEPC=$PIECE($PIECE(ADEV(ADEJ),U,2),",",ADEK)
+8 SET ADEPC=ADEPC_$SELECT($PIECE($PIECE(ADEV(ADEJ),U,4),",",ADEK)]"":"["_$PIECE($PIECE(ADEV(ADEJ),U,4),",",ADEK)_"]",1:"")
+9 SET ADEPC=ADEPC_$SELECT(($PIECE($PIECE(ADEV(ADEJ),U,5),",",ADEK)]"")&($PIECE(ADEV(ADEJ),U,2)'=""):"*",1:"")
+10 SET ADECNT=$LENGTH(ADEPC)+ADECNT+1
+11 DO L3
End DoDot:1
+12 SET ADEICL=$SELECT(ADEFLG:35,1:4)
SET ADENRQ=""
XECUTE ADEPRT
+13 GOTO L1
L2 KILL ADEJ
QUIT
L3 IF ADECNT>30
SET ADECNT=0
SET ADETXT=ADETXT_" "_ADEPC
SET ADEICL=$SELECT(ADEFLG:35,1:4)
SET ADENRQ=""
XECUTE ADEPRT
SET ADETXT=""
SET ADEFLG=1
QUIT
+1 SET ADETXT=ADETXT_" "_ADEPC
QUIT
