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
