BJPC2EV2.m

BJPC2EV2 ; IHS/CMI/LAB - PCC Suite v1.0 patch 1 environment check ;

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 ;

 ;

ASTHMASG ;conver v asthma severity to classification field in problem list

 D MES^XPDUTL("Converting V Asthma Severity to Problem List Classification")

 I '$O(^ATXAX("B","BGP ASTHMA DXS",0)) D MES^XPDUTL("Cannot convert....BGP ASTHMA DXS taxonomy missing") Q

 NEW BJPCP,BJPCD,BJPCE,BJPCL,BJPCS,BJPCED,BJPCV,BJPCT,BJPCF,BJPCX,BJPCDX,BGJPSS

 S BJPCP=0 F  S BJPCP=$O(^AUPNVAST("AS",BJPCP)) Q:BJPCP'=+BJPCP  D

 .S BJPCSS="" S BJPCD=0 F  S BJPCD=$O(^AUPNVAST("AS",BJPCP,BJPCD))  Q:BJPCD'=+BJPCD  D

 ..S BJPCL="",BJPCE=0 F  S BJPCE=$O(^AUPNVAST("AS",BJPCP,BJPCD,BJPCE)) Q:BJPCE'=+BJPCE  D

 ...S BJPCS=^AUPNVAST("AS",BJPCP,BJPCD,BJPCE)

 ...S S=$P($G(BJPCSS),U,1)

 ...I BJPCS'<S Q  ;already have a greater one

 ...S BJPCED=(9999999-BJPCD)

 ...S BJPCV=$P($G(^AUPNVAST(BJPCE,0)),U,3)

 ...S BJPCSS=BJPCS_U_BJPCED_U_BJPCV

 ..I BJPCSS]"" D UPDPROB

 Q

 ;

UPDPROB ;

 ;find existing asthma problem, if none add an active on

 S BJPCT=$O(^ATXAX("B","BGP ASTHMA DXS",0))

 S BJPCX=0,BJPCF=0 F  S BJPCX=$O(^AUPNPROB("AC",BJPCP,BJPCX)) Q:BJPCX'=+BJPCX  D

 .S BJPCDX=$P($G(^AUPNPROB(BJPCX,0)),U)

 .Q:BJPCDX=""

 .Q:'$$ICD^ATXCHK(BJPCDX,BJPCT,9)  ;NOT ON TAXONOMY

 .I $P(^AUPNPROB(BJPCX,0),U,15)="" S DA=BJPCX,DIE="^AUPNPROB(",DR=".15///"_$P(BJPCSS,U,1)_";.03////"_DT D ^DIE K DA,DIE,DR

 .S BJPCF=1

 Q:BJPCF  ;found one and updated it

 S BJPCDX="",BJPCDAT="",BJPCN=""

 K BJPCS

 S Y="BJPCS(",X=BJPCP_"^FIRST DX [BGP ASTHMA DXS" S E=$$START1^APCLDF(X,Y)

 I '$D(BJPCS(1)) Q  ;no asthma povs at all so quit

 S BJPCDX=$P(^AUPNVPOV(+$P(BJPCS(1),U,4),0),U)

 S BJPCN=$P(^AUPNVPOV(+$P(BJPCS(1),U,4),0),U,4)

 ;ADD PROBLEM WITH BJPCDX, BJPC

 D ADDPROB^APCDALV2("`"_BJPCDX,BJPCP,DT,"","`"_BJPCN,$P(^AUPNVSIT($P(BJPCS(1),U,5),0),U,6),DT,"A","",$P(BJPCSS,U,1),.5)

 Q

BJPC2EV2  ; IHS/CMI/LAB - PCC Suite v1.0 patch 1 environment check ;

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 +2       ;

 +3       ;

ASTHMASG  ;conver v asthma severity to classification field in problem list

 +1        DO MES^XPDUTL("Converting V Asthma Severity to Problem List Classification")

 +2        IF '$ORDER(^ATXAX("B","BGP ASTHMA DXS",0))

               DO MES^XPDUTL("Cannot convert....BGP ASTHMA DXS taxonomy missing")

               QUIT 

 +3        NEW BJPCP,BJPCD,BJPCE,BJPCL,BJPCS,BJPCED,BJPCV,BJPCT,BJPCF,BJPCX,BJPCDX,BGJPSS

 +4        SET BJPCP=0

           FOR 

               SET BJPCP=$ORDER(^AUPNVAST("AS",BJPCP))

               IF BJPCP'=+BJPCP

                   QUIT 

               Begin DoDot:1

 +5                SET BJPCSS=""

                   SET BJPCD=0

                   FOR 

                       SET BJPCD=$ORDER(^AUPNVAST("AS",BJPCP,BJPCD))

                       IF BJPCD'=+BJPCD

                           QUIT 

                       Begin DoDot:2

 +6                        SET BJPCL=""

                           SET BJPCE=0

                           FOR 

                               SET BJPCE=$ORDER(^AUPNVAST("AS",BJPCP,BJPCD,BJPCE))

                               IF BJPCE'=+BJPCE

                                   QUIT 

                               Begin DoDot:3

 +7                                SET BJPCS=^AUPNVAST("AS",BJPCP,BJPCD,BJPCE)

 +8                                SET S=$PIECE($GET(BJPCSS),U,1)

 +9       ;already have a greater one

                                   IF BJPCS'<S

                                       QUIT 

 +10                               SET BJPCED=(9999999-BJPCD)

 +11                               SET BJPCV=$PIECE($GET(^AUPNVAST(BJPCE,0)),U,3)

 +12                               SET BJPCSS=BJPCS_U_BJPCED_U_BJPCV

                               End DoDot:3

 +13                       IF BJPCSS]""

                               DO UPDPROB

                       End DoDot:2

               End DoDot:1

 +14       QUIT 

 +15      ;

UPDPROB   ;

 +1       ;find existing asthma problem, if none add an active on

 +2        SET BJPCT=$ORDER(^ATXAX("B","BGP ASTHMA DXS",0))

 +3        SET BJPCX=0

           SET BJPCF=0

           FOR 

               SET BJPCX=$ORDER(^AUPNPROB("AC",BJPCP,BJPCX))

               IF BJPCX'=+BJPCX

                   QUIT 

               Begin DoDot:1

 +4                SET BJPCDX=$PIECE($GET(^AUPNPROB(BJPCX,0)),U)

 +5                IF BJPCDX=""

                       QUIT 

 +6       ;NOT ON TAXONOMY

                   IF '$$ICD^ATXCHK(BJPCDX,BJPCT,9)

                       QUIT 

 +7                IF $PIECE(^AUPNPROB(BJPCX,0),U,15)=""

                       SET DA=BJPCX

                       SET DIE="^AUPNPROB("

                       SET DR=".15///"_$PIECE(BJPCSS,U,1)_";.03////"_DT

                       DO ^DIE

                       KILL DA,DIE,DR

 +8                SET BJPCF=1

               End DoDot:1

 +9       ;found one and updated it

           IF BJPCF

               QUIT 

 +10       SET BJPCDX=""

           SET BJPCDAT=""

           SET BJPCN=""

 +11       KILL BJPCS

 +12       SET Y="BJPCS("

           SET X=BJPCP_"^FIRST DX [BGP ASTHMA DXS"

           SET E=$$START1^APCLDF(X,Y)

 +13      ;no asthma povs at all so quit

           IF '$DATA(BJPCS(1))

               QUIT 

 +14       SET BJPCDX=$PIECE(^AUPNVPOV(+$PIECE(BJPCS(1),U,4),0),U)

 +15       SET BJPCN=$PIECE(^AUPNVPOV(+$PIECE(BJPCS(1),U,4),0),U,4)

 +16      ;ADD PROBLEM WITH BJPCDX, BJPC

 +17       DO ADDPROB^APCDALV2("`"_BJPCDX,BJPCP,DT,"","`"_BJPCN,$PIECE(^AUPNVSIT($PIECE(BJPCS(1),U,5),0),U,6),DT,"A","",$PIECE(BJPCSS,U,1),.5)

 +18       QUIT