APCHS9.m

APCHS9 ; IHS/CMI/LAB - PART 9 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;

 ;;2.0;IHS PCC SUITE;**2,7,8**;MAY 14, 2009;Build 2

 ;

 ;BJPC v1.0 patch 1

AST ;EP - called from supplement

 ;asthma dx ever or asthma on pl or ast

 NEW D,P,A

 S A=$O(^AUPNVAST("AA",APCHSPAT,0)) I A G AST1

 S A=$$PLAST^APCHSAST(APCHSPAT) I A]"" G AST1

 S A=$$DXAST^APCHSAST(APCHSPAT) I A G AST1

 Q

AST1 ;

 I $E(IOST)="C" D  I $D(DIRUT) S APCHSQIT=1 Q

 .W !! S DIR("A")="ASTHMA SUPPLEMENT WILL NOW BE DISPLAYED ("_"^"_" to exit, enter to continue)",DIR(0)="EO" KILL DA D ^DIR KILL DIR

 D EP^APCHSAST(APCHSPAT)

 Q

DENTAL ; ********** DENTAL SERVICES * 9002001 **********

 NEW X S X="ADERVW" X ^%ZOSF("TEST") I $T G PCC^ADERVW ; <SETUP>

 Q:'$D(^ADESVC(APCHSPAT))

 X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK

 ; <DISPLAY>

 W "<DENTAL SERVICES DISPLAY ROUTINE MISSING!>",!

 ; <CLEANUP>

DENTALX K X

 Q

 ;

 ;

MHSS ;EP ********* MENTAL HEALTH/SOCIAL SERVICES * 9002011

 NEW X S X="AMHHS" X ^%ZOSF("TEST") I $T G MH^AMHHS ; <SETUP>

 Q:'$D(^AMHREC("AC",APCHSPAT))

 X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK

 ; <DISPLAY>

 W "<MH/SS DISPLAY ROUTINE MISSING!>",!

 ; <CLEANUP>

MHSSX ;MHSS EXIT

 K X

 Q

CHR ;EP ********* CHR COMPONENT * 90002

 NEW X S X="BCHDHS" X ^%ZOSF("TEST") I $T G CHR^BCHDHS ; <SETUP>

 Q:'$D(^BCHR("AC",APCHSPAT))

 X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK

 ; <DISPLAY>

 W "<CHR DISPLAY ROUTINE MISSING!>",!

 ; <CLEANUP>

CHRX ;CHR EXIT

 K X

 Q

 ;

MCIS ; *********** MANAGED CARE MIS * 90001

 X APCHSCKP Q:$D(APCHSQIT)  W !!

 NEW X

 S X="BMCHS" X ^%ZOSF("TEST") I $T G HS^BMCHS ; write mcis summary

 G:'$D(^BMCREF("D",APCHSPAT)) MCISX ; exit if no referrals for patient

 X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK

 W "<MCIS DISPLAY ROUTINE MISSING!>",!

MCISX ;MCIS EXIT

 Q

 ;

PNOB ; *********** PN/OB COMPONENT

 ;IHS/CMI/LAB - added for new prenatal pacakge

 NEW X,AMCOHS,AMCODFN

 G:'$D(^AMCOB("B",APCHSPAT)) PNOBX ; exit if no referrals for patient

 S AMCOHS=1,DFN=APCHSPAT,AMCODFN=$$LASTPREG^AMCOUT2(DFN)

 I 'AMCODFN G PNOBX

 X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK

 S X="AMCOSUM1" X ^%ZOSF("TEST") I $T G ^AMCOSUM1 ; write pn/ob summary

 G:'$D(^AMCOB("B",APCHSPAT)) PNOBX ; exit if no referrals for patient

 X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK

 W "<PN/OB DISPLAY ROUTINE MISSING!>",!

PNOBX ;PNOB EXIT

 Q

CP ;EP

 NEW X S X="BCPSHSS" X ^%ZOSF("TEST") I '$T Q

 Q:'$D(^BCPP(DFN,0))  ;patient not in chronic patient file

 Q:'$D(^BCPA("AC",DFN))  ;no agreements

 I $E(IOST)="C" D  I $D(DIRUT) S APCHSQIT=1 Q

 .W !! S DIR("A")="CHRONIC PAIN SUPPLEMENT WILL NOW BE DISPLAYED ("_"^"_" to exit, enter to continue)",DIR(0)="EO" KILL DA D ^DIR KILL DIR

 D EP^BCPSHSS(APCHSPAT)

 Q

CP1 ;

 NEW X S X="BCPSHSS" X ^%ZOSF("TEST") I '$T W !!,"The chronic pain application is not installed." S APCHSUPQ=1 Q

 I '$D(^BCPP(DFN,0)) W !!,"This patient has no chronic pain agreements." S APCHSUPQ=1 Q  ;patient not in chronic patient file

 I '$D(^BCPA("AC",DFN)) W !!,"This patient has no chronic pain agreements." S APCHSUPQ=1 Q  ;no agreements

 Q

HMS ;

 NEW X S X="BKMVSUP" X ^%ZOSF("TEST") I '$T W !!,"The HMS is not installed." S APCHSUPQ=1 Q

 Q

WHP ;

 W !,"Women's Health Profile not available." S APCHSUPQ=1 Q

 Q

ANTICOAG ;EP - called from supplement

 ;has a diagnosis and a prescription for warfarin

 NEW D,P,A

 ;S A=$$LASTDX^APCHSMU2(APCHSPAT,"BJPC AC THRPY INDIC DXS",$$DOB^AUPNPAT(APCHSPAT),DT)

 S B=$$ACTWARF^APCHSTP1(APCHSPAT,$$FMADD^XLFDT(DT,-120),DT)

 I B G ANTICO1

 Q

ANTICO1 ;

 I $E(IOST)="C" D  I $D(DIRUT) S APCHSQIT=1 Q

 .W !! S DIR("A")="ANTI-COAGULATION SUPPLEMENT WILL NOW BE DISPLAYED ("_"^"_" to exit, enter to continue)",DIR(0)="EO" KILL DA D ^DIR KILL DIR

 D EP^APCHSACG(APCHSPAT)

 Q

APCHS9    ; IHS/CMI/LAB - PART 9 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;

 +1       ;;2.0;IHS PCC SUITE;**2,7,8**;MAY 14, 2009;Build 2

 +2       ;

 +3       ;BJPC v1.0 patch 1

AST       ;EP - called from supplement

 +1       ;asthma dx ever or asthma on pl or ast

 +2        NEW D,P,A

 +3        SET A=$ORDER(^AUPNVAST("AA",APCHSPAT,0))

           IF A

               GOTO AST1

 +4        SET A=$$PLAST^APCHSAST(APCHSPAT)

           IF A]""

               GOTO AST1

 +5        SET A=$$DXAST^APCHSAST(APCHSPAT)

           IF A

               GOTO AST1

 +6        QUIT 

AST1      ;

 +1        IF $EXTRACT(IOST)="C"

               Begin DoDot:1

 +2                WRITE !!

                   SET DIR("A")="ASTHMA SUPPLEMENT WILL NOW BE DISPLAYED ("_"^"_" to exit, enter to continue)"

                   SET DIR(0)="EO"

                   KILL DA

                   DO ^DIR

                   KILL DIR

               End DoDot:1

               IF $DATA(DIRUT)

                   SET APCHSQIT=1

                   QUIT 

 +3        DO EP^APCHSAST(APCHSPAT)

 +4        QUIT 

DENTAL    ; ********** DENTAL SERVICES * 9002001 **********

 +1       ; <SETUP>

           NEW X

           SET X="ADERVW"

           XECUTE ^%ZOSF("TEST")

           IF $TEST

               GOTO PCC^ADERVW

 +2        IF '$DATA(^ADESVC(APCHSPAT))

               QUIT 

 +3        XECUTE APCHSCKP

           IF $DATA(APCHSQIT)

               QUIT 

           IF 'APCHSNPG

               XECUTE APCHSBRK

 +4       ; <DISPLAY>

 +5        WRITE "<DENTAL SERVICES DISPLAY ROUTINE MISSING!>",!

 +6       ; <CLEANUP>

DENTALX    KILL X

 +1        QUIT 

 +2       ;

 +3       ;

MHSS      ;EP ********* MENTAL HEALTH/SOCIAL SERVICES * 9002011

 +1       ; <SETUP>

           NEW X

           SET X="AMHHS"

           XECUTE ^%ZOSF("TEST")

           IF $TEST

               GOTO MH^AMHHS

 +2        IF '$DATA(^AMHREC("AC",APCHSPAT))

               QUIT 

 +3        XECUTE APCHSCKP

           IF $DATA(APCHSQIT)

               QUIT 

           IF 'APCHSNPG

               XECUTE APCHSBRK

 +4       ; <DISPLAY>

 +5        WRITE "<MH/SS DISPLAY ROUTINE MISSING!>",!

 +6       ; <CLEANUP>

MHSSX     ;MHSS EXIT

 +1        KILL X

 +2        QUIT 

CHR       ;EP ********* CHR COMPONENT * 90002

 +1       ; <SETUP>

           NEW X

           SET X="BCHDHS"

           XECUTE ^%ZOSF("TEST")

           IF $TEST

               GOTO CHR^BCHDHS

 +2        IF '$DATA(^BCHR("AC",APCHSPAT))

               QUIT 

 +3        XECUTE APCHSCKP

           IF $DATA(APCHSQIT)

               QUIT 

           IF 'APCHSNPG

               XECUTE APCHSBRK

 +4       ; <DISPLAY>

 +5        WRITE "<CHR DISPLAY ROUTINE MISSING!>",!

 +6       ; <CLEANUP>

CHRX      ;CHR EXIT

 +1        KILL X

 +2        QUIT 

 +3       ;

MCIS      ; *********** MANAGED CARE MIS * 90001

 +1        XECUTE APCHSCKP

           IF $DATA(APCHSQIT)

               QUIT 

           WRITE !!

 +2        NEW X

 +3       ; write mcis summary

           SET X="BMCHS"

           XECUTE ^%ZOSF("TEST")

           IF $TEST

               GOTO HS^BMCHS

 +4       ; exit if no referrals for patient

           IF '$DATA(^BMCREF("D",APCHSPAT))

               GOTO MCISX

 +5        XECUTE APCHSCKP

           IF $DATA(APCHSQIT)

               QUIT 

           IF 'APCHSNPG

               XECUTE APCHSBRK

 +6        WRITE "<MCIS DISPLAY ROUTINE MISSING!>",!

MCISX     ;MCIS EXIT

 +1        QUIT 

 +2       ;

PNOB      ; *********** PN/OB COMPONENT

 +1       ;IHS/CMI/LAB - added for new prenatal pacakge

 +2        NEW X,AMCOHS,AMCODFN

 +3       ; exit if no referrals for patient

           IF '$DATA(^AMCOB("B",APCHSPAT))

               GOTO PNOBX

 +4        SET AMCOHS=1

           SET DFN=APCHSPAT

           SET AMCODFN=$$LASTPREG^AMCOUT2(DFN)

 +5        IF 'AMCODFN

               GOTO PNOBX

 +6        XECUTE APCHSCKP

           IF $DATA(APCHSQIT)

               QUIT 

           IF 'APCHSNPG

               XECUTE APCHSBRK

 +7       ; write pn/ob summary

           SET X="AMCOSUM1"

           XECUTE ^%ZOSF("TEST")

           IF $TEST

               GOTO ^AMCOSUM1

 +8       ; exit if no referrals for patient

           IF '$DATA(^AMCOB("B",APCHSPAT))

               GOTO PNOBX

 +9        XECUTE APCHSCKP

           IF $DATA(APCHSQIT)

               QUIT 

           IF 'APCHSNPG

               XECUTE APCHSBRK

 +10       WRITE "<PN/OB DISPLAY ROUTINE MISSING!>",!

PNOBX     ;PNOB EXIT

 +1        QUIT 

CP        ;EP

 +1        NEW X

           SET X="BCPSHSS"

           XECUTE ^%ZOSF("TEST")

           IF '$TEST

               QUIT 

 +2       ;patient not in chronic patient file

           IF '$DATA(^BCPP(DFN,0))

               QUIT 

 +3       ;no agreements

           IF '$DATA(^BCPA("AC",DFN))

               QUIT 

 +4        IF $EXTRACT(IOST)="C"

               Begin DoDot:1

 +5                WRITE !!

                   SET DIR("A")="CHRONIC PAIN SUPPLEMENT WILL NOW BE DISPLAYED ("_"^"_" to exit, enter to continue)"

                   SET DIR(0)="EO"

                   KILL DA

                   DO ^DIR

                   KILL DIR

               End DoDot:1

               IF $DATA(DIRUT)

                   SET APCHSQIT=1

                   QUIT 

 +6        DO EP^BCPSHSS(APCHSPAT)

 +7        QUIT 

CP1       ;

 +1        NEW X

           SET X="BCPSHSS"

           XECUTE ^%ZOSF("TEST")

           IF '$TEST

               WRITE !!,"The chronic pain application is not installed."

               SET APCHSUPQ=1

               QUIT 

 +2       ;patient not in chronic patient file

           IF '$DATA(^BCPP(DFN,0))

               WRITE !!,"This patient has no chronic pain agreements."

               SET APCHSUPQ=1

               QUIT 

 +3       ;no agreements

           IF '$DATA(^BCPA("AC",DFN))

               WRITE !!,"This patient has no chronic pain agreements."

               SET APCHSUPQ=1

               QUIT 

 +4        QUIT 

HMS       ;

 +1        NEW X

           SET X="BKMVSUP"

           XECUTE ^%ZOSF("TEST")

           IF '$TEST

               WRITE !!,"The HMS is not installed."

               SET APCHSUPQ=1

               QUIT 

 +2        QUIT 

WHP       ;

 +1        WRITE !,"Women's Health Profile not available."

           SET APCHSUPQ=1

           QUIT 

 +2        QUIT 

ANTICOAG  ;EP - called from supplement

 +1       ;has a diagnosis and a prescription for warfarin

 +2        NEW D,P,A

 +3       ;S A=$$LASTDX^APCHSMU2(APCHSPAT,"BJPC AC THRPY INDIC DXS",$$DOB^AUPNPAT(APCHSPAT),DT)

 +4        SET B=$$ACTWARF^APCHSTP1(APCHSPAT,$$FMADD^XLFDT(DT,-120),DT)

 +5        IF B

               GOTO ANTICO1

 +6        QUIT 

ANTICO1   ;

 +1        IF $EXTRACT(IOST)="C"

               Begin DoDot:1

 +2                WRITE !!

                   SET DIR("A")="ANTI-COAGULATION SUPPLEMENT WILL NOW BE DISPLAYED ("_"^"_" to exit, enter to continue)"

                   SET DIR(0)="EO"

                   KILL DA

                   DO ^DIR

                   KILL DIR

               End DoDot:1

               IF $DATA(DIRUT)

                   SET APCHSQIT=1

                   QUIT 

 +3        DO EP^APCHSACG(APCHSPAT)

 +4        QUIT