Routine: GMPLENFM

GMPLENFM ; SLC/MKB/KER/TC -- Problem List Enc Form utilities ;06/12/13  09:08

 ;;2.0;Problem List;**3,4,7,26,35,36,42**;Aug 25, 1994;Build 46

 ; External References

 ;   DBIA  1609  CONFIG^LEXSET

 ;   ICR   5699  $$ICDDATA^ICDXCODE, $$STATCHK^ICDXCODE

 ;   ICR   5747  $$CSI/SAB/CODECS^ICDEX

 ;   DBIA 10006  ^DIC

ACTIVE ; List of Active Problems for DFN

 ;   Input variables:

 ;             DFN               Patient ID (Required)

 ;             [GMPINDT]         Date of Interest (Optional - defaults to today)

 ;                                 This is the date to use for evalutation of the

 ;                                 Activation status of ICD-9-CM and SNOMED CT codes

 ;   Sets Global Array:

 ;   ^TMP("IB",$J,"INTERFACES",DFN,"GMP PATIENT ACTIVE PROBLEMS",#) =

 ;   Piece 1:  Problem text

 ;         2:  ICD code

 ;         3:  Date of Onset     00/00/00 format

 ;         4:  SC/NSC/""         serv-conn/not sc/unknown

 ;         5:  Y/N/""            serv-conn/not sc/unknown

 ;         6:  A/I/E/H/M/C/S/""  If problem is flagged as:

 ;                               A - Agent Orange

 ;                               I - Ionizing Radiation

 ;                               E - Environmental Contaminants

 ;                               H - Head/Neck Cancer

 ;                               M - Mil Sexual Trauma

 ;                               C - Combat Vet

 ;                               S - SHAD

 ;                                 - None

 ;         7:  Special Exposure  Full text of piece 6

 ;         8:  SNOMED-CT Concept Code

 ;         9:  SNOMED-CT Designation Code

 ;        10:  VHAT Concept VUID

 ;        11:  VHAT Designation VUID

 ;        12:  Code Status (#  -> ICD code inactive, $ -> SNOMED CT inactive,

 ;                          #$ -> Both ICD & SNOMED CT inactive, else "")

 ;        13:  ICD Coding System ("ICD": ICD-9-CM, "10D": ICD-10-CM)

 N IFN,PROB,CNT,SC,NUM,GMPLIST,GMPARAM,GMPLVIEW,GMPTOTAL

 N GMPDFN,NODE

 Q:$G(DFN)'>0  S GMPDFN=DFN,CNT=0,NODE=$G(^GMPL(125.99,1,0))

 S GMPINDT=$G(GMPINDT,$$DT^XLFDT)

 S GMPARAM("VER")=$P(NODE,U,2),GMPARAM("REV")=$P(NODE,U,5)="R",GMPARAM("QUIET")=1

 S GMPLVIEW("ACT")="A",GMPLVIEW("PROV")=0,GMPLVIEW("VIEW")=""

 D GETPLIST^GMPLMGR1(.GMPLIST,.GMPTOTAL,.GMPLVIEW)

 F NUM=0:0 S NUM=$O(GMPLIST(NUM)) Q:NUM'>0  D

 . N GMPL0,GMPL1,GMPL800,GMPL802,GMPCSYS,GMPDT,GMPLCPTR,CODESTAT,ICDC,ICDI,SCTC,SCTD,VHATC,VHATD

 . S IFN=GMPLIST(NUM) Q:IFN'>0

 . S GMPL0=$G(^AUPNPROB(IFN,0)),GMPL1=$G(^(1)),GMPL800=$G(^(800)),GMPL802=$G(^(802)),CODESTAT=""

 . S GMPDT=$S(+$P(GMPL802,U,1):$P(GMPL802,U,1),1:$P(GMPL0,U,8)),GMPLCPTR=$$CSI^ICDEX(80,+GMPL0)

 . S GMPCSYS=$S($P(GMPL802,U,2)]"":$P(GMPL802,U,2),1:$$SAB^ICDEX(GMPLCPTR,GMPDT))

 . S ICDC=$P($$ICDDATA^ICDXCODE(GMPCSYS,+GMPL0,GMPDT,"I"),U,2)

 . S:ICDC]"" CODESTAT=CODESTAT_$S(+$$STATCHK^ICDXCODE(GMPLCPTR,ICDC,GMPINDT):"",1:"#")

 . S ICDI=0 F  S ICDI=$O(^AUPNPROB(IFN,803,ICDI)) Q:+ICDI'>0  D

 .. N ICDM0,ICDMC,ICDMCSYS,ICDMDT,ICDCSPTR

 .. S ICDM0=$G(^AUPNPROB(IFN,803,ICDI,0)),ICDMC=$P(ICDM0,U)

 .. S ICDMCSYS=$P(ICDM0,U,2),ICDMDT=$P(ICDM0,U,3),ICDCSPTR=+$$CODECS^ICDEX(ICDMC,80,ICDMDT)

 .. S ICDC=ICDC_"/"_ICDMC

 .. I CODESTAT'["#" S CODESTAT=CODESTAT_$S(+$$STATCHK^ICDXCODE(ICDCSPTR,ICDMC,GMPINDT):"",1:"#")

 . S SCTC=$P(GMPL800,U),SCTD=$P(GMPL800,U,2),VHATC=$P(GMPL800,U,3),VHATD=$P(GMPL800,U,4)

 . S CODESTAT=CODESTAT_$S(+$$STATCHK^LEXSRC2(SCTC,GMPINDT,,"SCT"):"",1:"$")

 . S PROB=$$PROBTEXT^GMPLX(IFN),CNT=CNT+1

 . I GMPARAM("VER"),$P(GMPL1,U,2)="T" S PROB="$"_PROB

 . S PROB=PROB_U_ICDC

 . S PROB=PROB_U_$$EXTDT^GMPLX($P(GMPL0,U,13)),SC=$P(GMPL1,U,10)

 . S PROB=PROB_U_$S(+SC:"SC^Y",SC=0:"NSC^N",1:"^")

 . S PROB=PROB_U_$$TXFCTR(GMPL1)_U_SCTC_U_SCTD_U_VHATC_U_VHATD_U_CODESTAT_U_GMPCSYS

 . S ^TMP("IB",$J,"INTERFACES",+$G(DFN),"GMP PATIENT ACTIVE PROBLEMS",CNT)=PROB

 S ^TMP("IB",$J,"INTERFACES",+$G(DFN),"GMP PATIENT ACTIVE PROBLEMS",0)=CNT

SELECT ; Select Common Problems

 ;   Sets Global Array:

 ;   ^TMP("IB",$J,"INTERFACES","GMP SELECT CLINIC COMMON PROBLEMS")

 ;   Piece 1:  Pointer to Clinical Lexicon

 ;         2:  Problem Text

 ;         3:  ICD Code (null if unknown)

 N X,Y,DIC,PROB D CONFIG^LEXSET("GMPX","PLS")

 K ^TMP("IB",$J,"INTERFACES","GMP SELECT CLINIC COMMON PROBLEMS")

 S DIC("A")="Select PROBLEM: ",DIC(0)="AEQM",DIC="^LEX(757.01,"

 D ^DIC Q:+Y<0  S PROB=Y I +Y'>1 S PROB=+Y_U_X

 S PROB=PROB_U_$G(Y(1))

 S ^TMP("IB",$J,"INTERFACES","GMP SELECT CLINIC COMMON PROBLEMS")=PROB

DSELECT ; List of Active Problems for DFN

 ;   Input variables:

 ;             DFN               Patient ID (Required)

 ;             [GMPINDT]        Date of Interest (Optional - defaults to today)

 ;                                 This is the date to use for evalutation of the

 ;                                 Activation status of ICD-9-CM and SNOMED CT codes

 ;   Sets Global Array"

 ;   ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",#) =

 ;   Piece 1:  Problem IEN

 ;         2:  Problem Text

 ;         3:  ICD code

 ;         4:  Date of Onset     00/00/00 format

 ;         5:  SC/NSC/""         serv-conn/not sc/unknown

 ;         6:  Y/N/""            serv-conn/not sc/unknown

 ;         7:  A/I/E/H/M/C/S/""  If problem is flagged as:

 ;                               A - Agent Orange

 ;                               I - Ionizing Radiation

 ;                               E - Environmental Contaminants

 ;                               H - Head/Neck Cancer

 ;                               M - Mil Sexual Trauma

 ;                               C - Combat Vet

 ;                               S - SHAD

 ;                                 - None

 ;         8:  Special Exposure  Full text of piece 6

 ;         9:  SNOMED-CT Concept Code

 ;        10:  SNOMED-CT Designation Code

 ;        11:  VHAT Concept VUID

 ;        12:  VHAT Designation VUID

 ;        13:  Code Status (#  -> ICD code inactive, $ -> SNOMED CT inactive,

 ;                          #$ -> Both ICD & SNOMED CT inactive, else "")

 ;        14:  ICD coding system ("ICD": ICD-9-CM, "10D": ICD-10-CM)

 N IFN,PROB,CNT,SC,NUM,GMPLIST,GMPARAM,GMPLVIEW,GMPTOTAL,GMPDFN,NODE

 Q:$G(DFN)'>0  S GMPDFN=DFN,CNT=0,NODE=$G(^GMPL(125.99,1,0))

 S GMPINDT=$G(GMPINDT,$$DT^XLFDT)

 S GMPARAM("VER")=$P(NODE,U,2),GMPARAM("REV")=$P(NODE,U,5)="R",GMPARAM("QUIET")=1

 S GMPLVIEW("ACT")="A",GMPLVIEW("PROV")=0,GMPLVIEW("VIEW")=""

 D GETPLIST^GMPLMGR1(.GMPLIST,.GMPTOTAL,.GMPLVIEW)

 F NUM=0:0 S NUM=$O(GMPLIST(NUM)) Q:NUM'>0  D

 . N GMPL0,GMPL1,GMPL800,GMPL802,GMPDT,GMPCSYS,GMPLCPTR,CODESTAT,ICDC,ICDI,SCTC,SCTD,VHATC,VHATD

 . S IFN=GMPLIST(NUM) Q:IFN'>0

 . S GMPL0=$G(^AUPNPROB(IFN,0)),GMPL1=$G(^(1)),GMPL800=$G(^(800)),GMPL802=$G(^(802)),CODESTAT=""

 . S GMPDT=$S(+$P(GMPL802,U,1):$P(GMPL802,U,1),1:$P(GMPL0,U,8)),GMPLCPTR=$$CSI^ICDEX(80,+GMPL0)

 . S GMPCSYS=$S($P(GMPL802,U,2)]"":$P(GMPL802,U,2),1:$$SAB^ICDEX(GMPLCPTR,GMPDT))

 . S ICDC=$P($$ICDDATA^ICDXCODE(GMPCSYS,+GMPL0,GMPDT,"I"),U,2)

 . S:ICDC]"" CODESTAT=CODESTAT_$S(+$$STATCHK^ICDXCODE(GMPLCPTR,ICDC,GMPINDT):"",1:"#")

 . S ICDI=0 F  S ICDI=$O(^AUPNPROB(IFN,803,ICDI)) Q:+ICDI'>0  D

 .. N ICDM0,ICDMC,ICDMCSYS,ICDMDT,ICDCSPTR

 .. S ICDM0=$G(^AUPNPROB(IFN,803,ICDI,0)),ICDMC=$P(ICDM0,U) Q:ICDMC']""

 .. S ICDMCSYS=$P(ICDM0,U,2),ICDMDT=$P(ICDM0,U,3),ICDCSPTR=+$$CODECS^ICDEX(ICDMC,80,ICDMDT)

 .. S ICDC=ICDC_"/"_ICDMC

 .. I CODESTAT'["#" S CODESTAT=CODESTAT_$S(+$$STATCHK^ICDXCODE(ICDCSPTR,ICDMC,GMPINDT):"",1:"#")

 . S SCTC=$P(GMPL800,U),SCTD=$P(GMPL800,U,2),VHATC=$P(GMPL800,U,3),VHATD=$P(GMPL800,U,4)

 . S:SCTC]"" CODESTAT=CODESTAT_$S(+$$STATCHK^LEXSRC2(SCTC,GMPINDT,,"SCT"):"",1:"$")

 . S PROB=$$PROBTEXT^GMPLX(IFN),CNT=CNT+1

 . I GMPARAM("VER"),$P(GMPL1,U,2)="T" S PROB="$"_PROB

 . S PROB=IFN_U_PROB

 . S PROB=PROB_U_ICDC

 . S PROB=PROB_U_$$EXTDT^GMPLX($P(GMPL0,U,13)),SC=$P(GMPL1,U,10)

 . S PROB=PROB_U_$S(+SC:"SC^Y",SC=0:"NSC^N",1:"^")

 . S PROB=PROB_U_$$TXFCTR(GMPL1)_U_SCTC_U_SCTD_U_VHATC_U_VHATD_U_CODESTAT_U_GMPCSYS

 . S ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",CNT)=PROB

 S ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",0)=CNT

TXFCTR(GMPL1) ;Determine Treatment Factor, if any

 N NXTTF,TXFACTOR

 S TXFACTOR="^"

 F NXTTF=11,12,13,15,16,17,18 I $P(GMPL1,U,NXTTF) S TXFACTOR=$P("A^Agent Orange;I^Ionizing Radiation;E^Env. Contaminants;;H^Head/Neck Cancer;M^Mil Sexual Trauma;C^Combat Vet;S^SHAD",";",NXTTF-10) Q

 Q TXFACTOR

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMPLENFM   8540     printed  Mar 13, 2025@21:34:50                                                                                                                                                                                                    Page 2

GMPLENFM  ; SLC/MKB/KER/TC -- Problem List Enc Form utilities ;06/12/13  09:08

 +1       ;;2.0;Problem List;**3,4,7,26,35,36,42**;Aug 25, 1994;Build 46

 +2       ;

 +3       ; External References

 +4       ;   DBIA  1609  CONFIG^LEXSET

 +5       ;   ICR   5699  $$ICDDATA^ICDXCODE, $$STATCHK^ICDXCODE

 +6       ;   ICR   5747  $$CSI/SAB/CODECS^ICDEX

 +7       ;   DBIA 10006  ^DIC

 +8       ;

ACTIVE    ; List of Active Problems for DFN

 +1       ;   Input variables:

 +2       ;             DFN               Patient ID (Required)

 +3       ;             [GMPINDT]         Date of Interest (Optional - defaults to today)

 +4       ;                                 This is the date to use for evalutation of the

 +5       ;                                 Activation status of ICD-9-CM and SNOMED CT codes

 +6       ;

 +7       ;   Sets Global Array:

 +8       ;   ^TMP("IB",$J,"INTERFACES",DFN,"GMP PATIENT ACTIVE PROBLEMS",#) =

 +9       ;

 +10      ;   Piece 1:  Problem text

 +11      ;         2:  ICD code

 +12      ;         3:  Date of Onset     00/00/00 format

 +13      ;         4:  SC/NSC/""         serv-conn/not sc/unknown

 +14      ;         5:  Y/N/""            serv-conn/not sc/unknown

 +15      ;         6:  A/I/E/H/M/C/S/""  If problem is flagged as:

 +16      ;                               A - Agent Orange

 +17      ;                               I - Ionizing Radiation

 +18      ;                               E - Environmental Contaminants

 +19      ;                               H - Head/Neck Cancer

 +20      ;                               M - Mil Sexual Trauma

 +21      ;                               C - Combat Vet

 +22      ;                               S - SHAD

 +23      ;                                 - None

 +24      ;         7:  Special Exposure  Full text of piece 6

 +25      ;         8:  SNOMED-CT Concept Code

 +26      ;         9:  SNOMED-CT Designation Code

 +27      ;        10:  VHAT Concept VUID

 +28      ;        11:  VHAT Designation VUID

 +29      ;        12:  Code Status (#  -> ICD code inactive, $ -> SNOMED CT inactive,

 +30      ;                          #$ -> Both ICD & SNOMED CT inactive, else "")

 +31      ;        13:  ICD Coding System ("ICD": ICD-9-CM, "10D": ICD-10-CM)

 +32      ;

 +33       NEW IFN,PROB,CNT,SC,NUM,GMPLIST,GMPARAM,GMPLVIEW,GMPTOTAL

 +34       NEW GMPDFN,NODE

 +35       if $GET(DFN)'>0

               QUIT

           SET GMPDFN=DFN

           SET CNT=0

           SET NODE=$GET(^GMPL(125.99,1,0))

 +36       SET GMPINDT=$GET(GMPINDT,$$DT^XLFDT)

 +37       SET GMPARAM("VER")=$PIECE(NODE,U,2)

           SET GMPARAM("REV")=$PIECE(NODE,U,5)="R"

           SET GMPARAM("QUIET")=1

 +38       SET GMPLVIEW("ACT")="A"

           SET GMPLVIEW("PROV")=0

           SET GMPLVIEW("VIEW")=""

 +39       DO GETPLIST^GMPLMGR1(.GMPLIST,.GMPTOTAL,.GMPLVIEW)

 +40       FOR NUM=0:0

               SET NUM=$ORDER(GMPLIST(NUM))

               if NUM'>0

                   QUIT

               Begin DoDot:1

 +41               NEW GMPL0,GMPL1,GMPL800,GMPL802,GMPCSYS,GMPDT,GMPLCPTR,CODESTAT,ICDC,ICDI,SCTC,SCTD,VHATC,VHATD

 +42               SET IFN=GMPLIST(NUM)

                   if IFN'>0

                       QUIT

 +43               SET GMPL0=$GET(^AUPNPROB(IFN,0))

                   SET GMPL1=$GET(^(1))

                   SET GMPL800=$GET(^(800))

                   SET GMPL802=$GET(^(802))

                   SET CODESTAT=""

 +44               SET GMPDT=$SELECT(+$PIECE(GMPL802,U,1):$PIECE(GMPL802,U,1),1:$PIECE(GMPL0,U,8))

                   SET GMPLCPTR=$$CSI^ICDEX(80,+GMPL0)

 +45               SET GMPCSYS=$SELECT($PIECE(GMPL802,U,2)]"":$PIECE(GMPL802,U,2),1:$$SAB^ICDEX(GMPLCPTR,GMPDT))

 +46               SET ICDC=$PIECE($$ICDDATA^ICDXCODE(GMPCSYS,+GMPL0,GMPDT,"I"),U,2)

 +47               if ICDC]""

                       SET CODESTAT=CODESTAT_$SELECT(+$$STATCHK^ICDXCODE(GMPLCPTR,ICDC,GMPINDT):"",1:"#")

 +48               SET ICDI=0

FOR

                       SET ICDI=$ORDER(^AUPNPROB(IFN,803,ICDI))

                       if +ICDI'>0

                           QUIT

                       Begin DoDot:2

 +49                       NEW ICDM0,ICDMC,ICDMCSYS,ICDMDT,ICDCSPTR

 +50                       SET ICDM0=$GET(^AUPNPROB(IFN,803,ICDI,0))

                           SET ICDMC=$PIECE(ICDM0,U)

 +51                       SET ICDMCSYS=$PIECE(ICDM0,U,2)

                           SET ICDMDT=$PIECE(ICDM0,U,3)

                           SET ICDCSPTR=+$$CODECS^ICDEX(ICDMC,80,ICDMDT)

 +52                       SET ICDC=ICDC_"/"_ICDMC

 +53                       IF CODESTAT'["#"

                               SET CODESTAT=CODESTAT_$SELECT(+$$STATCHK^ICDXCODE(ICDCSPTR,ICDMC,GMPINDT):"",1:"#")

                       End DoDot:2

 +54               SET SCTC=$PIECE(GMPL800,U)

                   SET SCTD=$PIECE(GMPL800,U,2)

                   SET VHATC=$PIECE(GMPL800,U,3)

                   SET VHATD=$PIECE(GMPL800,U,4)

 +55               SET CODESTAT=CODESTAT_$SELECT(+$$STATCHK^LEXSRC2(SCTC,GMPINDT,,"SCT"):"",1:"$")

 +56               SET PROB=$$PROBTEXT^GMPLX(IFN)

                   SET CNT=CNT+1

 +57               IF GMPARAM("VER")

                       IF $PIECE(GMPL1,U,2)="T"

                           SET PROB="$"_PROB

 +58               SET PROB=PROB_U_ICDC

 +59               SET PROB=PROB_U_$$EXTDT^GMPLX($PIECE(GMPL0,U,13))

                   SET SC=$PIECE(GMPL1,U,10)

 +60               SET PROB=PROB_U_$SELECT(+SC:"SC^Y",SC=0:"NSC^N",1:"^")

 +61               SET PROB=PROB_U_$$TXFCTR(GMPL1)_U_SCTC_U_SCTD_U_VHATC_U_VHATD_U_CODESTAT_U_GMPCSYS

 +62               SET ^TMP("IB",$JOB,"INTERFACES",+$GET(DFN),"GMP PATIENT ACTIVE PROBLEMS",CNT)=PROB

               End DoDot:1

 +63       SET ^TMP("IB",$JOB,"INTERFACES",+$GET(DFN),"GMP PATIENT ACTIVE PROBLEMS",0)=CNT

 +64       QUIT

 +65      ;

SELECT    ; Select Common Problems

 +1       ;   Sets Global Array:

 +2       ;   ^TMP("IB",$J,"INTERFACES","GMP SELECT CLINIC COMMON PROBLEMS")

 +3       ;   Piece 1:  Pointer to Clinical Lexicon

 +4       ;         2:  Problem Text

 +5       ;         3:  ICD Code (null if unknown)

 +6       ;

 +7        NEW X,Y,DIC,PROB

           DO CONFIG^LEXSET("GMPX","PLS")

 +8        KILL ^TMP("IB",$JOB,"INTERFACES","GMP SELECT CLINIC COMMON PROBLEMS")

 +9        SET DIC("A")="Select PROBLEM: "

           SET DIC(0)="AEQM"

           SET DIC="^LEX(757.01,"

 +10       DO ^DIC

           if +Y<0

               QUIT

           SET PROB=Y

           IF +Y'>1

               SET PROB=+Y_U_X

 +11       SET PROB=PROB_U_$GET(Y(1))

 +12       SET ^TMP("IB",$JOB,"INTERFACES","GMP SELECT CLINIC COMMON PROBLEMS")=PROB

 +13       QUIT

 +14      ;

DSELECT   ; List of Active Problems for DFN

 +1       ;   Input variables:

 +2       ;             DFN               Patient ID (Required)

 +3       ;             [GMPINDT]        Date of Interest (Optional - defaults to today)

 +4       ;                                 This is the date to use for evalutation of the

 +5       ;                                 Activation status of ICD-9-CM and SNOMED CT codes

 +6       ;

 +7       ;   Sets Global Array"

 +8       ;   ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",#) =

 +9       ;

 +10      ;   Piece 1:  Problem IEN

 +11      ;         2:  Problem Text

 +12      ;         3:  ICD code

 +13      ;         4:  Date of Onset     00/00/00 format

 +14      ;         5:  SC/NSC/""         serv-conn/not sc/unknown

 +15      ;         6:  Y/N/""            serv-conn/not sc/unknown

 +16      ;         7:  A/I/E/H/M/C/S/""  If problem is flagged as:

 +17      ;                               A - Agent Orange

 +18      ;                               I - Ionizing Radiation

 +19      ;                               E - Environmental Contaminants

 +20      ;                               H - Head/Neck Cancer

 +21      ;                               M - Mil Sexual Trauma

 +22      ;                               C - Combat Vet

 +23      ;                               S - SHAD

 +24      ;                                 - None

 +25      ;         8:  Special Exposure  Full text of piece 6

 +26      ;         9:  SNOMED-CT Concept Code

 +27      ;        10:  SNOMED-CT Designation Code

 +28      ;        11:  VHAT Concept VUID

 +29      ;        12:  VHAT Designation VUID

 +30      ;        13:  Code Status (#  -> ICD code inactive, $ -> SNOMED CT inactive,

 +31      ;                          #$ -> Both ICD & SNOMED CT inactive, else "")

 +32      ;        14:  ICD coding system ("ICD": ICD-9-CM, "10D": ICD-10-CM)

 +33      ;

 +34       NEW IFN,PROB,CNT,SC,NUM,GMPLIST,GMPARAM,GMPLVIEW,GMPTOTAL,GMPDFN,NODE

 +35       if $GET(DFN)'>0

               QUIT

           SET GMPDFN=DFN

           SET CNT=0

           SET NODE=$GET(^GMPL(125.99,1,0))

 +36       SET GMPINDT=$GET(GMPINDT,$$DT^XLFDT)

 +37       SET GMPARAM("VER")=$PIECE(NODE,U,2)

           SET GMPARAM("REV")=$PIECE(NODE,U,5)="R"

           SET GMPARAM("QUIET")=1

 +38       SET GMPLVIEW("ACT")="A"

           SET GMPLVIEW("PROV")=0

           SET GMPLVIEW("VIEW")=""

 +39       DO GETPLIST^GMPLMGR1(.GMPLIST,.GMPTOTAL,.GMPLVIEW)

 +40       FOR NUM=0:0

               SET NUM=$ORDER(GMPLIST(NUM))

               if NUM'>0

                   QUIT

               Begin DoDot:1

 +41               NEW GMPL0,GMPL1,GMPL800,GMPL802,GMPDT,GMPCSYS,GMPLCPTR,CODESTAT,ICDC,ICDI,SCTC,SCTD,VHATC,VHATD

 +42               SET IFN=GMPLIST(NUM)

                   if IFN'>0

                       QUIT

 +43               SET GMPL0=$GET(^AUPNPROB(IFN,0))

                   SET GMPL1=$GET(^(1))

                   SET GMPL800=$GET(^(800))

                   SET GMPL802=$GET(^(802))

                   SET CODESTAT=""

 +44               SET GMPDT=$SELECT(+$PIECE(GMPL802,U,1):$PIECE(GMPL802,U,1),1:$PIECE(GMPL0,U,8))

                   SET GMPLCPTR=$$CSI^ICDEX(80,+GMPL0)

 +45               SET GMPCSYS=$SELECT($PIECE(GMPL802,U,2)]"":$PIECE(GMPL802,U,2),1:$$SAB^ICDEX(GMPLCPTR,GMPDT))

 +46               SET ICDC=$PIECE($$ICDDATA^ICDXCODE(GMPCSYS,+GMPL0,GMPDT,"I"),U,2)

 +47               if ICDC]""

                       SET CODESTAT=CODESTAT_$SELECT(+$$STATCHK^ICDXCODE(GMPLCPTR,ICDC,GMPINDT):"",1:"#")

 +48               SET ICDI=0

FOR

                       SET ICDI=$ORDER(^AUPNPROB(IFN,803,ICDI))

                       if +ICDI'>0

                           QUIT

                       Begin DoDot:2

 +49                       NEW ICDM0,ICDMC,ICDMCSYS,ICDMDT,ICDCSPTR

 +50                       SET ICDM0=$GET(^AUPNPROB(IFN,803,ICDI,0))

                           SET ICDMC=$PIECE(ICDM0,U)

                           if ICDMC']""

                               QUIT

 +51                       SET ICDMCSYS=$PIECE(ICDM0,U,2)

                           SET ICDMDT=$PIECE(ICDM0,U,3)

                           SET ICDCSPTR=+$$CODECS^ICDEX(ICDMC,80,ICDMDT)

 +52                       SET ICDC=ICDC_"/"_ICDMC

 +53                       IF CODESTAT'["#"

                               SET CODESTAT=CODESTAT_$SELECT(+$$STATCHK^ICDXCODE(ICDCSPTR,ICDMC,GMPINDT):"",1:"#")

                       End DoDot:2

 +54               SET SCTC=$PIECE(GMPL800,U)

                   SET SCTD=$PIECE(GMPL800,U,2)

                   SET VHATC=$PIECE(GMPL800,U,3)

                   SET VHATD=$PIECE(GMPL800,U,4)

 +55               if SCTC]""

                       SET CODESTAT=CODESTAT_$SELECT(+$$STATCHK^LEXSRC2(SCTC,GMPINDT,,"SCT"):"",1:"$")

 +56               SET PROB=$$PROBTEXT^GMPLX(IFN)

                   SET CNT=CNT+1

 +57               IF GMPARAM("VER")

                       IF $PIECE(GMPL1,U,2)="T"

                           SET PROB="$"_PROB

 +58               SET PROB=IFN_U_PROB

 +59               SET PROB=PROB_U_ICDC

 +60               SET PROB=PROB_U_$$EXTDT^GMPLX($PIECE(GMPL0,U,13))

                   SET SC=$PIECE(GMPL1,U,10)

 +61               SET PROB=PROB_U_$SELECT(+SC:"SC^Y",SC=0:"NSC^N",1:"^")

 +62               SET PROB=PROB_U_$$TXFCTR(GMPL1)_U_SCTC_U_SCTD_U_VHATC_U_VHATD_U_CODESTAT_U_GMPCSYS

 +63               SET ^TMP("IB",$JOB,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",CNT)=PROB

               End DoDot:1

 +64       SET ^TMP("IB",$JOB,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",0)=CNT

 +65       QUIT

 +66      ;

TXFCTR(GMPL1) ;Determine Treatment Factor, if any

 +1        NEW NXTTF,TXFACTOR

 +2        SET TXFACTOR="^"

 +3        FOR NXTTF=11,12,13,15,16,17,18

               IF $PIECE(GMPL1,U,NXTTF)

                   SET TXFACTOR=$PIECE("A^Agent Orange;I^Ionizing Radiation;E^Env. Contaminants;;H^Head/Neck Cancer;M^Mil Sexual Trauma;C^Combat Vet;S^SHAD",";",NXTTF-10)

                   QUIT

 +4        QUIT TXFACTOR

GMPLENFM.m