- 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
