BHSDEN.m

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       ;