Routine: BHSPLST2

BHSPLST2 ;IHS/MSC/MGH  - Health Summary for Problem list;04-Jan-2016 10:17;DU

 ;;1.0;HEALTH SUMMARY COMPONENTS;**13**;Mar 17,2006;Build 6

 ; IHS/CMI/LAB - PART 4 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;31-Mar-2014 16:53;DU

ICPR(DFN,TARGET,TYPE,ACTIVE) ;Care plans by problem

 N ARRAY,INVDT,VCNT,CNT,STAT,NARR,X,Y,Z,SIGN,SIGNDT,CDTE,EDATE

 K @TARGET

 S CNT=0,ARRAY="",ACTIVE=$G(ACTIVE)

 D GETPROB2(.ARRAY,DFN,TYPE,ACTIVE)

 S X=""  F  S X=$O(ARRAY(X)) Q:X=""  D

 .S PRIEN=X

 .S STAT=$$GET1^DIQ(9000011,PRIEN,.12)

 .S PNAR=$$GET1^DIQ(9000011,PRIEN,.05)

 .S CONCT=$$GET1^DIQ(9000011,PRIEN,80001)

 .S CNT=CNT+1

 .S @TARGET@(CNT,0)="Problem: "_PNAR

 .S CNT=CNT+1

 .S @TARGET@(CNT,0)=" - Problem Status: "_STAT

 .S Z="" F  S Z=$O(ARRAY(X,Z)) Q:Z=""  D

 ..S Y="" F  S Y=$O(ARRAY(X,Z,Y)) Q:Y=""  D

 ...S EDATE=9999999-$P(ARRAY(X,Z,Y),U,2)

 ...S EDATE=$$FMTE^XLFDT(EDATE,5)

 ...S SIGN=$P(ARRAY(X,Z,Y),U,4)

 ...S SIGNDT=$P(ARRAY(X,Z,Y),U,6)

 ...S CDTE=$P(ARRAY(X,Z,Y),U,8)

 ...S CNT=CNT+1

 ...S @TARGET@(CNT,0)=" - Date: "_EDATE

 ...S CNT=CNT+1

 ...S @TARGET@(CNT,0)=" - TEXT  Status: "_CDTE

 ...S CPIEN=$P(ARRAY(X,Z,Y),U,3)

 ...D TEXT^BTIUPV1(TYPE,CPIEN)

 I CNT=0 S @TARGET@(1,0)="No Care Plans found of type "_$S(TYPE="G":"Goal",1:"Care Plan")

 Q "~@"_$NA(@TARGET)

GETPROB2(ARRAY,DFN,TYPE,ACTIVE) ;EP

 ;Start by finding the patient's problems

 N PRIEN,REC,CONCT,PNAR,STAT,VCNT

 S PRIEN="",VCNT=0

 F  S PRIEN=$O(^AUPNPROB("AC",DFN,PRIEN)) Q:'PRIEN  D

 .S REC=$G(^AUPNPROB(PRIEN,0))

 .S STAT=$P(REC,U,12)

 .Q:STAT="D"!(STAT="I")  ;Only doing active problems

 .D GETPL(.ARRAY,PRIEN,TYPE,ACTIVE)

GETPL(ARRAY,PRIEN,TYPE,ACTIVE) ;Return data

 N INVDT,STATUS,CPIEN,SIEN,DATA

 S CPIEN="",DATA=""

 F  S CPIEN=$O(^AUPNCPL("APT",PRIEN,TYPE,CPIEN)) Q:CPIEN=""  D

 .S SIEN=$C(0) S SIEN=$O(^AUPNCPL(CPIEN,11,SIEN),-1)  Q:'+SIEN  D

 ..S STATUS=$P($G(^AUPNCPL(CPIEN,11,SIEN,0)),U,1)

 ..Q:ACTIVE="I"&(STATUS="A")

 ..Q:STATUS="E"

 ..S INVDT=9999999-$P($G(^AUPNCPL(CPIEN,0)),U,5)

 ..S DATA=$$DATA(CPIEN,SIEN,ACTIVE)

 ..Q:DATA=""

 ..S VCNT=VCNT+1

 ..S ARRAY(PRIEN,INVDT,VCNT)=PRIEN_U_INVDT_U_DATA

DATA(CPIEN,SIEN,ACTIVE) ;Get data for this item

 N BY,WHEN,LIEN,TXT,TXTIEN,PTYPE,SIGNED,PROB,SIG,FNUM,NODE,EVDT

 S FNUM=9000092.11

 S SIGNED=0

 S SIGNED=$P($G(^AUPNCPL(CPIEN,0)),U,7)

 S EVDT=$P($G(^AUPNCPL(CPIEN,0)),U,5)

 Q:(SIGNED="")&(DUZ'=$$GET1^DIQ(9000092,CPIEN,.03,"I")) ""

 S NODE=$G(^AUPNCPL(CPIEN,11,SIEN,0))

 S LIEN=SIEN_","_CPIEN

 S WHEN=$$GET1^DIQ(FNUM,LIEN,.03,"I")

 S WHEN=$$FMTDATE^BGOUTL(WHEN)

 S BY=$$GET1^DIQ(9000092,CPIEN,.07,"E")

 S STAT=$$GET1^DIQ(FNUM,LIEN,.01,"I")

 Q:ACTIVE="I"&(STAT="A") ""

 Q:STAT="E" ""

 S SIG=$$GET1^DIQ(9000092,CPIEN,.08,"I")

 I SIG'="" S SIG=$$FMTDATE^BGOUTL(SIG)

 Q CPIEN_U_BY_U_WHEN_U_SIG_U_EVDT_U_STAT

BHSPLST2  ;IHS/MSC/MGH  - Health Summary for Problem list;04-Jan-2016 10:17;DU

 +1       ;;1.0;HEALTH SUMMARY COMPONENTS;**13**;Mar 17,2006;Build 6

 +2       ; IHS/CMI/LAB - PART 4 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;31-Mar-2014 16:53;DU

 +3       ;

ICPR(DFN,TARGET,TYPE,ACTIVE) ;Care plans by problem

 +1        NEW ARRAY,INVDT,VCNT,CNT,STAT,NARR,X,Y,Z,SIGN,SIGNDT,CDTE,EDATE

 +2        KILL @TARGET

 +3        SET CNT=0

           SET ARRAY=""

           SET ACTIVE=$GET(ACTIVE)

 +4        DO GETPROB2(.ARRAY,DFN,TYPE,ACTIVE)

 +5        SET X=""

FOR

               SET X=$ORDER(ARRAY(X))

               IF X=""

                   QUIT

               Begin DoDot:1

 +6                SET PRIEN=X

 +7                SET STAT=$$GET1^DIQ(9000011,PRIEN,.12)

 +8                SET PNAR=$$GET1^DIQ(9000011,PRIEN,.05)

 +9                SET CONCT=$$GET1^DIQ(9000011,PRIEN,80001)

 +10               SET CNT=CNT+1

 +11               SET @TARGET@(CNT,0)="Problem: "_PNAR

 +12               SET CNT=CNT+1

 +13               SET @TARGET@(CNT,0)=" - Problem Status: "_STAT

 +14               SET Z=""

FOR

                       SET Z=$ORDER(ARRAY(X,Z))

                       IF Z=""

                           QUIT

                       Begin DoDot:2

 +15                       SET Y=""

FOR

                               SET Y=$ORDER(ARRAY(X,Z,Y))

                               IF Y=""

                                   QUIT

                               Begin DoDot:3

 +16                               SET EDATE=9999999-$PIECE(ARRAY(X,Z,Y),U,2)

 +17                               SET EDATE=$$FMTE^XLFDT(EDATE,5)

 +18                               SET SIGN=$PIECE(ARRAY(X,Z,Y),U,4)

 +19                               SET SIGNDT=$PIECE(ARRAY(X,Z,Y),U,6)

 +20                               SET CDTE=$PIECE(ARRAY(X,Z,Y),U,8)

 +21                               SET CNT=CNT+1

 +22                               SET @TARGET@(CNT,0)=" - Date: "_EDATE

 +23                               SET CNT=CNT+1

 +24                               SET @TARGET@(CNT,0)=" - TEXT  Status: "_CDTE

 +25                               SET CPIEN=$PIECE(ARRAY(X,Z,Y),U,3)

 +26                               DO TEXT^BTIUPV1(TYPE,CPIEN)

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +27       IF CNT=0

               SET @TARGET@(1,0)="No Care Plans found of type "_$SELECT(TYPE="G":"Goal",1:"Care Plan")

 +28       QUIT "~@"_$NAME(@TARGET)

 +29      ;

GETPROB2(ARRAY,DFN,TYPE,ACTIVE) ;EP

 +1       ;Start by finding the patient's problems

 +2        NEW PRIEN,REC,CONCT,PNAR,STAT,VCNT

 +3        SET PRIEN=""

           SET VCNT=0

 +4        FOR

               SET PRIEN=$ORDER(^AUPNPROB("AC",DFN,PRIEN))

               IF 'PRIEN

                   QUIT

               Begin DoDot:1

 +5                SET REC=$GET(^AUPNPROB(PRIEN,0))

 +6                SET STAT=$PIECE(REC,U,12)

 +7       ;Only doing active problems

                   IF STAT="D"!(STAT="I")

                       QUIT

 +8                DO GETPL(.ARRAY,PRIEN,TYPE,ACTIVE)

               End DoDot:1

 +9        QUIT

GETPL(ARRAY,PRIEN,TYPE,ACTIVE) ;Return data

 +1        NEW INVDT,STATUS,CPIEN,SIEN,DATA

 +2        SET CPIEN=""

           SET DATA=""

 +3        FOR

               SET CPIEN=$ORDER(^AUPNCPL("APT",PRIEN,TYPE,CPIEN))

               IF CPIEN=""

                   QUIT

               Begin DoDot:1

 +4                SET SIEN=$CHAR(0)

                   SET SIEN=$ORDER(^AUPNCPL(CPIEN,11,SIEN),-1)

                   IF '+SIEN

                       QUIT

                   Begin DoDot:2

 +5                    SET STATUS=$PIECE($GET(^AUPNCPL(CPIEN,11,SIEN,0)),U,1)

 +6                    IF ACTIVE="I"&(STATUS="A")

                           QUIT

 +7                    IF STATUS="E"

                           QUIT

 +8                    SET INVDT=9999999-$PIECE($GET(^AUPNCPL(CPIEN,0)),U,5)

 +9                    SET DATA=$$DATA(CPIEN,SIEN,ACTIVE)

 +10                   IF DATA=""

                           QUIT

 +11                   SET VCNT=VCNT+1

 +12                   SET ARRAY(PRIEN,INVDT,VCNT)=PRIEN_U_INVDT_U_DATA

                   End DoDot:2

               End DoDot:1

 +13       QUIT

DATA(CPIEN,SIEN,ACTIVE) ;Get data for this item

 +1        NEW BY,WHEN,LIEN,TXT,TXTIEN,PTYPE,SIGNED,PROB,SIG,FNUM,NODE,EVDT

 +2        SET FNUM=9000092.11

 +3        SET SIGNED=0

 +4        SET SIGNED=$PIECE($GET(^AUPNCPL(CPIEN,0)),U,7)

 +5        SET EVDT=$PIECE($GET(^AUPNCPL(CPIEN,0)),U,5)

 +6        IF (SIGNED="")&(DUZ'=$$GET1^DIQ(9000092,CPIEN,.03,"I"))

               QUIT ""

 +7        SET NODE=$GET(^AUPNCPL(CPIEN,11,SIEN,0))

 +8        SET LIEN=SIEN_","_CPIEN

 +9        SET WHEN=$$GET1^DIQ(FNUM,LIEN,.03,"I")

 +10       SET WHEN=$$FMTDATE^BGOUTL(WHEN)

 +11       SET BY=$$GET1^DIQ(9000092,CPIEN,.07,"E")

 +12       SET STAT=$$GET1^DIQ(FNUM,LIEN,.01,"I")

 +13       IF ACTIVE="I"&(STAT="A")

               QUIT ""

 +14       IF STAT="E"

               QUIT ""

 +15       SET SIG=$$GET1^DIQ(9000092,CPIEN,.08,"I")

 +16       IF SIG'=""

               SET SIG=$$FMTDATE^BGOUTL(SIG)

 +17       QUIT CPIEN_U_BY_U_WHEN_U_SIG_U_EVDT_U_STAT

BHSPLST2.m