BHSAAP1.m

BHSAAP1 ;IHS/MSC/MGH  - Health summmary for asthma action plan;06-May-2010 10:41;MGH

 ;;1.0;HEALTH SUMMARY COMONENTS;**4**;March 17, 2006;Build 13

 ;Copy of APCHAAP1 to print out an asthma action plan

EHR ; ;EP

 N BHSRELM,BHSRESM,BHSRZC,BHSRZY

 D CKP^GMTSUP Q:$D(GMTSQIT)

 W:$D(^AUPNPAT(DFN,41,DUZ(2),0)) !,"Patient's chart number is ",$P(^(0),U,2),! W !

RELMED ;

 S BHSRELM=$P($$REDZONE(DFN),U)  ;get last recorded red zone instructions

 I BHSRELM="" S BHSRZC="B" G RESMED

 E  S BHSRZC="E" G RESMED

RESMED ;

 S BHSRESM=$P($$YELZONE(DFN),U)  ;get last recorded YELLOW zone instructions

 I BHSRESM="" S BHSRZY="B"

 E  S BHSRZY="E"

PRINT ;Print out the health summary

 D PRINT^BHSAAP2

 Q

REDZONE(P) ;EP - get last recorded red zone instructions

 NEW R,D,I,S

 S R=""  ;instructions

 S D=""

 S S=""

 F  S D=$O(^AUPNVAST("AA",P,D)) Q:D'=+D!(R]"")  D

 .S I=0 F  S I=$O(^AUPNVAST("AA",P,D,I)) Q:I'=+I!(R]"")  D

 ..S R=$P($G(^AUPNVAST(I,13)),U,1),S=9999999-D

 ..Q

 .Q

 Q R_U_S

YELZONE(P) ;EP - get last recorded yellow zone instructions

 NEW R,D,I

 S R=""  ;instructions

 S D="",S=""

 F  S D=$O(^AUPNVAST("AA",P,D)) Q:D'=+D!(R]"")  D

 .S I=0 F  S I=$O(^AUPNVAST("AA",P,D,I)) Q:I'=+I!(R]"")  D

 ..S R=$P($G(^AUPNVAST(I,11)),U,1),S=9999999-D

 ..Q

 .Q

 Q R_U_S

HEAD ;

 ;I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCHQ=1 Q

HEAD1 ;

 ;W:$D(IOF) @IOF

 W !,$P(^DIC(4,DUZ(2),0),U),?53,"Today's Date: ",$$FMTE^XLFDT(DT),!

 W "Patient Name: ",$P(^DPT(DFN,0),U)

 W ?45,"Birth Date: ",$$DOB^AUPNPAT(DFN,"E")

 W ?71,"Age: ",$$AGE^AUPNPAT(DFN),!

 W $$REPEAT^XLFSTR("_",79),!!

 Q

CTR(X,Y) ;EP - Center X in a field Y wide.

 Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X

 ;----------

BHSAAP1   ;IHS/MSC/MGH  - Health summmary for asthma action plan;06-May-2010 10:41;MGH

 +1       ;;1.0;HEALTH SUMMARY COMONENTS;**4**;March 17, 2006;Build 13

 +2       ;Copy of APCHAAP1 to print out an asthma action plan

EHR       ; ;EP

 +1        NEW BHSRELM,BHSRESM,BHSRZC,BHSRZY

 +2        DO CKP^GMTSUP

           IF $DATA(GMTSQIT)

               QUIT 

 +3        IF $DATA(^AUPNPAT(DFN,41,DUZ(2),0))

               WRITE !,"Patient's chart number is ",$PIECE(^(0),U,2),!

           WRITE !

RELMED    ;

 +1       ;get last recorded red zone instructions

           SET BHSRELM=$PIECE($$REDZONE(DFN),U)

 +2        IF BHSRELM=""

               SET BHSRZC="B"

               GOTO RESMED

 +3       IF '$TEST

               SET BHSRZC="E"

               GOTO RESMED

RESMED    ;

 +1       ;get last recorded YELLOW zone instructions

           SET BHSRESM=$PIECE($$YELZONE(DFN),U)

 +2        IF BHSRESM=""

               SET BHSRZY="B"

 +3       IF '$TEST

               SET BHSRZY="E"

PRINT     ;Print out the health summary

 +1        DO PRINT^BHSAAP2

 +2        QUIT 

REDZONE(P) ;EP - get last recorded red zone instructions

 +1        NEW R,D,I,S

 +2       ;instructions

           SET R=""

 +3        SET D=""

 +4        SET S=""

 +5        FOR 

               SET D=$ORDER(^AUPNVAST("AA",P,D))

               IF D'=+D!(R]"")

                   QUIT 

               Begin DoDot:1

 +6                SET I=0

                   FOR 

                       SET I=$ORDER(^AUPNVAST("AA",P,D,I))

                       IF I'=+I!(R]"")

                           QUIT 

                       Begin DoDot:2

 +7                        SET R=$PIECE($GET(^AUPNVAST(I,13)),U,1)

                           SET S=9999999-D

 +8                        QUIT 

                       End DoDot:2

 +9                QUIT 

               End DoDot:1

 +10       QUIT R_U_S

YELZONE(P) ;EP - get last recorded yellow zone instructions

 +1        NEW R,D,I

 +2       ;instructions

           SET R=""

 +3        SET D=""

           SET S=""

 +4        FOR 

               SET D=$ORDER(^AUPNVAST("AA",P,D))

               IF D'=+D!(R]"")

                   QUIT 

               Begin DoDot:1

 +5                SET I=0

                   FOR 

                       SET I=$ORDER(^AUPNVAST("AA",P,D,I))

                       IF I'=+I!(R]"")

                           QUIT 

                       Begin DoDot:2

 +6                        SET R=$PIECE($GET(^AUPNVAST(I,11)),U,1)

                           SET S=9999999-D

 +7                        QUIT 

                       End DoDot:2

 +8                QUIT 

               End DoDot:1

 +9        QUIT R_U_S

HEAD      ;

 +1       ;I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCHQ=1 Q

HEAD1     ;

 +1       ;W:$D(IOF) @IOF

 +2        WRITE !,$PIECE(^DIC(4,DUZ(2),0),U),?53,"Today's Date: ",$$FMTE^XLFDT(DT),!

 +3        WRITE "Patient Name: ",$PIECE(^DPT(DFN,0),U)

 +4        WRITE ?45,"Birth Date: ",$$DOB^AUPNPAT(DFN,"E")

 +5        WRITE ?71,"Age: ",$$AGE^AUPNPAT(DFN),!

 +6        WRITE $$REPEAT^XLFSTR("_",79),!!

 +7        QUIT 

CTR(X,Y)  ;EP - Center X in a field Y wide.

 +1        QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X

 +2       ;----------