- BHSDEN ;IHS/CIA/MGH - Health Summary for Dental ;17-Mar-2006 10:36;MGH
- ;;1.0;HEALTH SUMMARY COMPONENTS;;March 17, 2006
- ;===================================================================
- ;Taken from ADERVW
- ;IHS/HQT/MJL - DENTAL CHART REVW PART 1 ; [ 03/24/1999 9:04 AM ]
- ;;6.0;ADE;;APRIL 1999
- ;VA health sumary routine for dental data
- START ; EP
- N ADEPCC,ADEADA,ADEBRK,ADEC,ADECAT,ADECKP,ADECVD,ADEDAT,ADEDFN,ADEDLM,ADEDLT,ADEDTD,ADEDTU,ADEF,ADEFLG,ADEFO,ADEHD2,ADEHDR,ADEICL,ADEILN
- N ADEMDFN,ADENDM,ADENDN,ADENFLG,ADENOD,ADENRQ,ADENSH,ADEOP,ADEPG,ADEPRT,ADEQ,ADER,ADESFC,ADESFN,ADESITE,ADESITX,ADESUB,ADESUBD,ADESVD
- N ADETXT,ADETYP,ADETYPN,ADEX,ADEY,X,Y,%
- N ADECNT,ADEDES,ADEJ,ADENOT,ADEPC,ADEPRV,ADEREP,ADEV,ADENDMS
- S ADEPCC=1
- D INIT
- ;------->LIST FOLLOWUP, FAILED APPTS
- D DO^BHSDEN2
- ;------->LIST DENTAL PROCEDURES
- D DO^BHSDEN1
- ;------->CALL TURNAROUND FORM FROM HERE
- D:$D(ADETUR) DO^BHSDTUR
- ;------->RETURN TO CALLING ROUTINE
- END ;EP
- D CKP^GMTSUP Q:$D(GMTSQIT)
- KILL I 'ADEPCC D ^%ZISC K BHSQIT,BHSNPG
- K ADEADA,ADEBRK,ADEC,ADECAT,ADECKP,ADECVD,ADEDAT,ADEDFN,ADEDLM,ADEDLT,ADEDTD,ADEDTU,ADEF,ADEFLG,ADEFO,ADEHD2,ADEHDR,ADEICL,ADEILN
- K ADEMDFN,ADENDM,ADENDN,ADENOD,ADENRQ,ADENSH,ADEOP,ADEPG,ADEPRT,ADEQ,ADER,ADESFC,ADESFN,ADESITE,ADESITX,ADESUB,ADESUBD,ADESVD
- K ADETXT,ADETYP,ADETYPN,ADEX,ADEY,ADELAST
- K ADECNT,ADEDES,ADEJ,ADENOT,ADEPC,ADEPRV,ADEREP,ADEV,ADENDMS
- K ADEPCC,ADETUR,ADEZ
- Q
- ;
- INIT I '$D(ADEPCC) S Y=0 Q
- G:'ADEPCC I2
- ;
- S ADEPAT=BHSPAT
- S ADEDLM=GMTSDLM,ADENDM=GMTSNDM
- S ADEPRT="D PRTTXT^BHSDEN0"
- S ADESITX="D GETSITE^BHSDEN0"
- S Y=1
- Q
- I2 ;EP
- S ADEPG=0
- S %="CONFIDENTIAL PATIENT DATA",$P(ADEHDR,"*",(IOM-$L(%)/2))=%,$P(ADEHDR,"*",IOM-$L(%))=""
- S ADEPRT="D PRTTXT^BHSDEN0"
- S ADESITX="D GETSITE^BHSDEN0"
- I $P(IOST,"-")="C" S ADECKP=ADECKP_"W *7,""<>"" R X:DTIME S:'$T X=U W *13 S:X[U BHSQIT="""" I '$D(BHSQIT) "
- S ADECKP=ADECKP_"W @IOF D HEADER^BHSDEN0 S GMTSNPG=1"
- I $D(DUZ(2)),DUZ(2),$D(^ADEPARAM(DUZ(2),0)) S ADEDLM=$P(^ADEPARAM(DUZ(2),0),U,9) S ADEDLM=$S(ADEDLM["D":ADEDLM,ADEDLM["M":ADEDLM*30,ADEDLM["Y":ADEDLM*365,1:5*365)
- S:'$D(ADEDLM) ADEDLM=5*365
- S X1=DT,X2=-ADEDLM D C^%DTC S ADEDLM=9999999-X K X1,X2
- S:$D(ADELAST) ADENDM=1
- I '$D(ADENDM),$D(DUZ(2)),DUZ(2),$D(^ADEPARAM(DUZ(2),0)) S ADENDM=$P(^ADEPARAM(DUZ(2),0),U,8) S:'ADENDM ADENDM=10
- S:'$D(ADENDM) ADENDM=10
- S ADECVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$E(Y,6,7)_""/""_$E(Y,2,3)"
- U IO W @IOF D HEADER^BHSDEN0 S GMTSNPG=1
- S Y=1 Q
- QUE N ZTRTN,ZTDESC,ZTSAVE
- S ZTRTN="START^BHSDEN",ZTDESC="DENTAL PATIENT INQUIRE",ZTSAVE("ADEPAT")="",ZTSAVE("ADEPCC")="" D ^%ZTLOAD Q
- ;
- BHSDEN ;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 ADERVW
- +4 ;IHS/HQT/MJL - DENTAL CHART REVW PART 1 ; [ 03/24/1999 9:04 AM ]
- +5 ;;6.0;ADE;;APRIL 1999
- +6 ;VA health sumary routine for dental data
- START ; EP
- +1 NEW ADEPCC,ADEADA,ADEBRK,ADEC,ADECAT,ADECKP,ADECVD,ADEDAT,ADEDFN,ADEDLM,ADEDLT,ADEDTD,ADEDTU,ADEF,ADEFLG,ADEFO,ADEHD2,ADEHDR,ADEICL,ADEILN
- +2 NEW ADEMDFN,ADENDM,ADENDN,ADENFLG,ADENOD,ADENRQ,ADENSH,ADEOP,ADEPG,ADEPRT,ADEQ,ADER,ADESFC,ADESFN,ADESITE,ADESITX,ADESUB,ADESUBD,ADESVD
- +3 NEW ADETXT,ADETYP,ADETYPN,ADEX,ADEY,X,Y,%
- +4 NEW ADECNT,ADEDES,ADEJ,ADENOT,ADEPC,ADEPRV,ADEREP,ADEV,ADENDMS
- +5 SET ADEPCC=1
- +6 DO INIT
- +7 ;------->LIST FOLLOWUP, FAILED APPTS
- +8 DO DO^BHSDEN2
- +9 ;------->LIST DENTAL PROCEDURES
- +10 DO DO^BHSDEN1
- +11 ;------->CALL TURNAROUND FORM FROM HERE
- +12 IF $DATA(ADETUR)
- DO DO^BHSDTUR
- +13 ;------->RETURN TO CALLING ROUTINE
- END ;EP
- +1 DO CKP^GMTSUP
- IF $DATA(GMTSQIT)
- QUIT
- KILL IF 'ADEPCC
- DO ^%ZISC
- KILL BHSQIT,BHSNPG
- +1 KILL ADEADA,ADEBRK,ADEC,ADECAT,ADECKP,ADECVD,ADEDAT,ADEDFN,ADEDLM,ADEDLT,ADEDTD,ADEDTU,ADEF,ADEFLG,ADEFO,ADEHD2,ADEHDR,ADEICL,ADEILN
- +2 KILL ADEMDFN,ADENDM,ADENDN,ADENOD,ADENRQ,ADENSH,ADEOP,ADEPG,ADEPRT,ADEQ,ADER,ADESFC,ADESFN,ADESITE,ADESITX,ADESUB,ADESUBD,ADESVD
- +3 KILL ADETXT,ADETYP,ADETYPN,ADEX,ADEY,ADELAST
- +4 KILL ADECNT,ADEDES,ADEJ,ADENOT,ADEPC,ADEPRV,ADEREP,ADEV,ADENDMS
- +5 KILL ADEPCC,ADETUR,ADEZ
- +6 QUIT
- +7 ;
- INIT IF '$DATA(ADEPCC)
- SET Y=0
- QUIT
- +1 IF 'ADEPCC
- GOTO I2
- +2 ;
- +3 SET ADEPAT=BHSPAT
- +4 SET ADEDLM=GMTSDLM
- SET ADENDM=GMTSNDM
- +5 SET ADEPRT="D PRTTXT^BHSDEN0"
- +6 SET ADESITX="D GETSITE^BHSDEN0"
- +7 SET Y=1
- +8 QUIT
- I2 ;EP
- +1 SET ADEPG=0
- +2 SET %="CONFIDENTIAL PATIENT DATA"
- SET $PIECE(ADEHDR,"*",(IOM-$LENGTH(%)/2))=%
- SET $PIECE(ADEHDR,"*",IOM-$LENGTH(%))=""
- +3 SET ADEPRT="D PRTTXT^BHSDEN0"
- +4 SET ADESITX="D GETSITE^BHSDEN0"
- +5 IF $PIECE(IOST,"-")="C"
- SET ADECKP=ADECKP_"W *7,""<>"" R X:DTIME S:'$T X=U W *13 S:X[U BHSQIT="""" I '$D(BHSQIT) "
- +6 SET ADECKP=ADECKP_"W @IOF D HEADER^BHSDEN0 S GMTSNPG=1"
- +7 IF $DATA(DUZ(2))
- IF DUZ(2)
- IF $DATA(^ADEPARAM(DUZ(2),0))
- SET ADEDLM=$PIECE(^ADEPARAM(DUZ(2),0),U,9)
- SET ADEDLM=$SELECT(ADEDLM["D":ADEDLM,ADEDLM["M":ADEDLM*30,ADEDLM["Y":ADEDLM*365,1:5*365)
- +8 IF '$DATA(ADEDLM)
- SET ADEDLM=5*365
- +9 SET X1=DT
- SET X2=-ADEDLM
- DO C^%DTC
- SET ADEDLM=9999999-X
- KILL X1,X2
- +10 IF $DATA(ADELAST)
- SET ADENDM=1
- +11 IF '$DATA(ADENDM)
- IF $DATA(DUZ(2))
- IF DUZ(2)
- IF $DATA(^ADEPARAM(DUZ(2),0))
- SET ADENDM=$PIECE(^ADEPARAM(DUZ(2),0),U,8)
- IF 'ADENDM
- SET ADENDM=10
- +12 IF '$DATA(ADENDM)
- SET ADENDM=10
- +13 SET ADECVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$E(Y,6,7)_""/""_$E(Y,2,3)"
- +14 USE IO
- WRITE @IOF
- DO HEADER^BHSDEN0
- SET GMTSNPG=1
- +15 SET Y=1
- QUIT
- QUE NEW ZTRTN,ZTDESC,ZTSAVE
- +1 SET ZTRTN="START^BHSDEN"
- SET ZTDESC="DENTAL PATIENT INQUIRE"
- SET ZTSAVE("ADEPAT")=""
- SET ZTSAVE("ADEPCC")=""
- DO ^%ZTLOAD
- QUIT
- +2 ;
