ORQQPL3 ; ALB/PDR/REV ; Problem List RPC's ; 8-OCT-1998 09:08:49.29
 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,148,173**;Dec 17, 1997
 ;
 ;---------------- LIST PATIENT PROBLEMS ------------------------
 ;
PROBL(ROOT,DFN,CONTEXT)        ;  GET LIST OF PATIENT PROBLEMS
 N DIWL,DIWR,DIWF
 N ST,ORI,ORX
 S (LCNT,NUM)=0
 S DIWL=1,DIWR=48,DIWF="C48"
 S CONTEXT=";;"_$G(CONTEXT)
 I CONTEXT=";;" S CONTEXT=";;A"
 S ST=$P(CONTEXT,";",3)
 ;
 I ST="R" D DELLIST(.ROOT,+DFN) ; show deleted only
 I ST'="R"  D LIST(.ROOT,+DFN,ST) ; show others - don't trust ELSE here
 ;
 I ROOT(0)<1 D
 . S LCNT=1
 . S ROOT(1)="     "_$$PAD^ORCHTAB("No data available.",49)_"|"
 Q
 ;
 ;
LIST(GMPL,GMPDFN,GMPSTAT)       ; -- Returns list of problems for patient GMPDFN
 ;    in GMPL(#)=ifn^status^description^ICD^onset^last modified^SC^SpExp^Condition^Loc^
 ;                          loc.type^prov^service
 ;     & GMPL(0)=number of problems returned
 ; This is virtually same as LIST^GMPLUTL2 except that it appends the 
 ; condition - T)ranscribed or P)ermanent,location,loc type,provider, service.
 ;
 N I,IFN,CNT,GMPL0,GMPL1,SP,ST,NUM,ONSET,ICD,LASTMOD,PRIO,DTREC
 N SC,ORLIST,ORVIEW,GMPARAM,ORTOTAL,LIN,LOC,LT,PROV,SERV,HASCMT
 N SCCOND,AO,IR,ENV,HNC,MST,ORICD186,INACT
 Q:$G(GMPDFN)'>0
 S CNT=0,SP=""
 S GMPARAM("QUIET")=1
 S GMPARAM("REV")=$P($G(^GMPL(125.99,1,0)),U,5)="R"
 S ORVIEW("ACT")=GMPSTAT
 S ORVIEW("PROV")=0
 S ORVIEW("VIEW")=""
 S ORICD186=$$PATCH^XPDUTL("ICD*18.0*6")
 ;
 D GETPLIST^GMPLMGR1(.ORLIST,.ORTOTAL,.ORVIEW)
 ;
 F NUM=0:0 S NUM=$O(ORLIST(NUM)) Q:NUM'>0  D
 . S IFN=+ORLIST(NUM) Q:IFN'>0
 . S INACT=""
 . S GMPL0=$G(^AUPNPROB(IFN,0))
 . S GMPL1=$G(^AUPNPROB(IFN,1))
 . S HASCMT=($D(^AUPNPROB(IFN,11,0))>0)
 . S CNT=CNT+1
 . I +ORICD186 D
 . . S ICD=$$CODEC^ICDCODE(+GMPL0)
 . . I '+$$STATCHK^ICDAPIU(ICD,DT) S INACT="#"
 . E  D
 . . S ICD=$P($G(^ICD9(+GMPL0,0)),U)
 . S LASTMOD=$P(GMPL0,U,3)
 . S ST=$P(GMPL0,U,12)
 . S ONSET=$P(GMPL0,U,13)
 . S SC=$S(+$P(GMPL1,U,10):"SC",$P(GMPL1,U,10)=0:"NSC",1:"")
 . S AO=$S(+$P(GMPL1,U,11):"/AO",1:"")
 . S IR=$S(+$P(GMPL1,U,12):"/IR",1:"")
 . S ENV=$S(+$P(GMPL1,U,13):"/EC",1:"")
 . S HNC=$S(+$P(GMPL1,U,15):"/HNC",1:"")
 . S MST=$S(+$P(GMPL1,U,16):"/MST",1:"")
 . S SCCOND=SC_AO_IR_ENV_HNC_MST
 . S LOC=$P(GMPL1,U,8)
 . S DTREC=$P(GMPL1,U,9)
 . S LT=""
 . I LOC'="" S LT=$P($G(^SC(LOC,0)),"^",3),LOC=LOC_";"_$P($G(^SC(LOC,0)),U,1)
 . S PROV=$P(GMPL1,U,5) ; responsible provider
 . I PROV'="" S PROV=PROV_";"_$P($G(^VA(200,PROV,0)),U,1)
 . S SERV=$P(GMPL1,U,6)
 . I SERV=0 S SERV="" ; not sure how it gets set to 0, but need consistency in GUI
 . I SERV'="" S SERV=SERV_";"_$P($G(^DIC(49,SERV,0)),U,1)
 . S SP=""
 . F I=11,12,13 S:$P(GMPL1,U,I) SP=SP_$S(I=11:"A",I=12:"I",1:"P")
 . S PRIO=$P(GMPL1,U,14)
 . S LIN=IFN_U_ST_U_$$PROBTEXT^GMPLX(IFN)_U_ICD_U_ONSET
 . S LIN=LIN_U_LASTMOD_U_SC_U_SP_U_$P(GMPL1,U,2)
 . S LIN=LIN_U_LOC_U_LT_U_PROV_U_SERV_U_PRIO_U_HASCMT_U_DTREC_U_SCCOND_U_INACT
 . S GMPL(CNT)=LIN
 S GMPL(0)=CNT
 Q
 ;
 ;
 ;------------------------------------- GET LIST OF DELETED PROBLEMS -----------------------------
 ;
DELLIST(RETURN,GMPDFN) ; GET LIST OF DELETED PROBLEMS
 ; see GETPLIST^GMPLMGR1 and LIST^GMPUTL2
 N S,IFN,I,L0,L1,ST,TXT,ICD,ONSET,MOD,SC,SP,LOC,LT,PROV,SERV,PRIO,HASCMT,DTREC
 N SCCOND,AO,IR,ENV,HNC,MST,ORICD186,INACT
 S I=0,S=""
 S ORICD186=$$PATCH^XPDUTL("ICD*18.0*6")
 F  S S=$O(^AUPNPROB("ACTIVE",GMPDFN,S)) Q:S=""  D
 . S IFN=""
 . F  S IFN=$O(^AUPNPROB("ACTIVE",+GMPDFN,S,IFN)) Q:IFN=""  D
 .. I $P($G(^AUPNPROB(IFN,1)),U,2)="H" D
 ... S L0=$G(^AUPNPROB(IFN,0))
 ... Q:L0=""
 ... S INACT=""
 ... S L1=$G(^AUPNPROB(IFN,1))
 ... S ST=$P(L0,U,12)
 ... S TXT=$$PROBTEXT^GMPLX(IFN)
 ... I +ORICD186 D
 ... . S ICD=$$CODEC^ICDCODE(+L0)
 ... . I '+$$STATCHK^ICDAPIU(ICD,DT) S INACT="#"
 ... E  D
 ... . S ICD=$P($G(^ICD9(+L0,0)),U)
 ... S ONSET=$P(L0,U,13)
 ... S MOD=$P(L0,U,3)
 ... S SC=$S(+$P(L1,U,10):"SC",$P(L1,U,10)=0:"NSC",1:"")
 ... S AO=$S(+$P(L1,U,11):"/AO",1:"")
 ... S IR=$S(+$P(L1,U,12):"/IR",1:"")
 ... S ENV=$S(+$P(L1,U,13):"/EC",1:"")
 ... S HNC=$S(+$P(L1,U,15):"/HNC",1:"")
 ... S MST=$S(+$P(L1,U,16):"/MST",1:"")
 ... S SCCOND=SC_AO_IR_ENV_HNC_MST
 ... S SP=$$GETSP
 ... S LOC=$P(L1,U,8)
 ... S LT=""
 ... I LOC'="" S LT=$P($G(^SC(LOC,0)),"^",3)
 ... S PROV=$P(L1,U,5) ; responsible provider
 ... S SERV=$P(L1,U,6)
 ... S PRIO=$P(L1,U,14)
 ... S HASCMT=($D(^AUPNPROB(IFN,11,0))>0)
 ... S DTREC=$P(L1,U,9)
 ... S I=I+1
 ... S RETURN(I)=IFN_U_ST_U_TXT_U_ICD_U_ONSET
 ... S RETURN(I)=RETURN(I)_U_MOD_U_SC_U_SP_U_$P(L1,U,2)
 ... S RETURN(I)=RETURN(I)_U_LOC_U_LT_U_PROV_U_SERV
 ... S RETURN(I)=RETURN(I)_U_PRIO_U_HASCMT_U_DTREC_U_SCCOND_U_INACT
 S RETURN(0)=I
 Q
 ;
GETSP() ; GET EXPOSURES
 N I
 S SP=""
 F I=11,12,13 S:$P(L1,U,I) SP=SP_$S(I=11:"A",I=12:"I",1:"P")
 Q SP
 ;
 ; adapted from ^GMPLBLD3 ;9/96
 ;
 ; ----------------------- GET USER PROBLEM CATEGORIES --------------
 ;
CAT(TMP,ORDUZ,CLIN) ; Get user category list
 N GSEQ,GCNT,GROUP,HDR,IFN,LCNT,ITEM,TG,GMPLSLST
 ; S TG=$NAME(^TMP("GMPLMENU",$J)) ; put list in global for testing
 S TG=$NAME(TMP) ; put list in local
 K @TG
 S (GSEQ,GCNT,LCNT)=0
 ;
 S GMPLSLST=$$GETUSLST(DUZ,CLIN)  ; get approp list for user
 ; Build multiple of category\problems
 ; Iterate categories
 F  S GSEQ=$O(^GMPL(125.1,"C",+GMPLSLST,GSEQ)) Q:GSEQ'>0  D
 . S IFN=$O(^GMPL(125.1,"C",+GMPLSLST,GSEQ,0)) Q:IFN'>0
 . S ITEM=$G(^GMPL(125.1,IFN,0))
 . S GROUP=+$P(ITEM,U,3)
 . S HDR=GROUP_U_$P(ITEM,U,4,5)
 . S GCNT=GCNT+1
 . S @TG@(GCNT)=HDR ; put category into temp global
 Q
 ;
GETUSLST(ORDUZ,CLIN) ; GET AN APPROPRIATE CATEGORY LIST FOR THE USER
 N GMPLSLST
 S GMPLSLST=$P($G(^VA(200,DUZ,125)),U,2)
 ;I 'GMPLSLST D
 I 'GMPLSLST,CLIN,$D(^GMPL(125,"C",+CLIN)) S GMPLSLST=$O(^(+CLIN,0))
 ;. S GMPLSLST=$O(^VA(200,DUZ,+CLIN,0))  ;$O(^(+CLIN,0))
 Q GMPLSLST
 ;
 ;----------------------- USER PROBLEM LIST --------------------------
 ;
PROB(TMP,GROUP) ; Get user problem list for given group
 N PSEQ,PCNT,IFN,ITEM,TG,CODE,TEXT,ORICD186
 ; S TG=$NAME(^TMP("GMPLMENU",$J)) ; put list in global for testing
 S TG=$NAME(TMP) ; put list in local
 K @TG
 S LCNT=0
 S ORICD186=$$PATCH^XPDUTL("ICD*18.0*6")
 ;
 ; iterate through problems in category
 S (PSEQ,PCNT)=0
 F  S PSEQ=$O(^GMPL(125.12,"C",GROUP,PSEQ)) Q:PSEQ'>0  D
 . S IFN=$O(^GMPL(125.12,"C",GROUP,PSEQ,0)) Q:IFN'>0
 . S ITEM=$G(^GMPL(125.12,IFN,0))
 . S TEXT=$P(ITEM,U,4)
 . ; SEE DD for GMPL(125.12,4 :
 . ; "...code which is to be displayed... generally assumed to be ICD"
 . S CODE=$P(ITEM,U,5)
 . I +ORICD186,'+$$STATCHK^ICDAPIU(CODE,DT) Q
 . S PCNT=PCNT+1
 . ; RETURN:
 . ; PROBLEM^DISPLAY TEXT^CODE^CODE IFN
 . I +ORICD186 D
 . . S @TG@(PCNT)=$P(ITEM,U,3,5)_U_$$CODEN^ICDCODE(CODE,80)
 . E  D
 . . S @TG@(PCNT)=$P(ITEM,U,3,5)_U_$$ICDCODE(CODE)
 Q
 ;
ICDCODE(COD)    ; RETURN INTERNAL ICD FOR EXTERNAL CODE  (obsolete after CSV patches released - RV)
 N CODIEN
 I COD="" Q ""
 S CODIEN=+$O(^ICD9("AB",$P(COD,U)_" ",0))
 S:CODIEN'>0 CODIEN=+$O(^ICD9("AB",$P(COD,U)_"0 ",0))
 Q CODIEN
 ;
 ;------------------ Filter Providers ---------------------
 ;
GETRPRV(RETURN,INP) ; GET LIST OF RESPONSIBLE PROVIDERS FROM PRBLM LIST 
 ; RETURN - aa list of responsible providers from which to select for filtering
 ; INP - array of problem list providers to select from
 ;
 N S
 S S=""
 F I=1:1 S S=$O(INP(S)) Q:S=""  D
 . I INP(S)'="",$G(^VA(200,INP(S),0))'="" D  Q  ; get next
 .. S RETURN(I)=INP(S)_U_$P(^VA(200,INP(S),0),U)
 S RETURN(0)="-1"_U_"<None recorded>" ; return empty provider
 Q
 ;
 ;---------------------------------------------------- GET FILTERED CLINIC LIST ------------------------
 ;
GETCLIN(RETURN,INP) ; Get FILTERED LIST OF CLINICS
 ; RETURN NAMES FOR LIST OF CLINICS PASSED IN
 N I,S
 S S=""
 F I=1:1 S S=$O(INP(S)) Q:S=""  D
 . I INP(S)'="",$G(^SC(INP(S),0))'="" D  Q  ; get next
 .. S RETURN(I)=INP(S)_U_$P(^SC(INP(S),0),U,1)
 ;. S RETURN(I)="-1"_U_"None" ; return empty location
 Q
 ;
GETSRVC(RETURN,INP) ; GET FILTERED LIST OF INPATIENT SERVICES
 ; RETURN NAMES FOR LIST OF IEN PASSED IN
 N I,S
 S S=""
 F I=1:1 S S=$O(INP(S)) Q:S=""  D
 . I INP(S)'="",$G(^DIC(49,INP(S),0))'="" D  Q  ; get next
 .. S RETURN(I)=INP(S)_U_$P(^DIC(49,INP(S),0),U,1)
 ;. S RETURN(I)="-1"_U_"None" ; return empty service
 Q