Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ORQQPL1

ORQQPL1.m

Go to the documentation of this file. 
  1. ORQQPL1 ; ALB/PDR/REV - PROBLEM LIST FOR CPRS GUI ; 02/12/08
  1.  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,148,173,203,206,249,243**;Dec 17, 1997;Build 242
  1.  ;
  1.  ;------------------------- GET PROBLEM FROM LEXICON -------------------
  1.  ;
  1. LEXSRCH(LIST,FROM,N,VIEW,ORDATE) ; Get candidate Problems from LEX file
  1.  N LEX,VAL,VAL1,COD,CIEN,SYS,MAX,NAME
  1.  S:'+$G(ORDATE) ORDATE=DT
  1.  S:'$G(N) N=100
  1.  S:'$L($G(VIEW)) VIEW="PL1"
  1.  D CONFIG^LEXSET("GMPL",VIEW,ORDATE)
  1.  D LOOK^LEXA(FROM,"GMPL",N,"",ORDATE)
  1.  S S=0
  1.  F  S S=$O(LEX("LIST",S)) Q:S<1  D
  1.  . S VAL1=LEX("LIST",S)
  1.  . S COD="",CIEN="",SYS="",NAME=""
  1.  . I $L(VAL1,"CPT-4 ")>1 D
  1.  .. S SYS="ICD-9-CM "
  1.  .. S COD="799.9"
  1.  .. S CIEN=""
  1.  .. S NAME=$P(VAL1," (CPT-4")
  1.  . I $L(VAL1,"DSM-IV ")>1 D
  1.  .. S SYS="DSM-IV "
  1.  .. S COD=$P($P(VAL1,SYS,2),")")
  1.  .. S:COD["/" COD=$P(COD,"/",1)
  1.  .. S CIEN=$$CODEN^ICDCODE($$ICDONE^LEXU($P(VAL1,U,1),ORDATE),80)
  1.  .. S NAME=$P(VAL1," (DSM-IV")
  1.  .. ;
  1.  . I $L(VAL1,"(TITLE 38 ")>1 D
  1.  .. S SYS="TITLE 38 "
  1.  .. S COD=$P($P(VAL1,SYS,2),")")
  1.  .. S:COD["/" COD=$P(COD,"/",1)
  1.  .. S CIEN=$$CODEN^ICDCODE($$ICDONE^LEXU($P(VAL1,U,1),ORDATE),80)
  1.  .. S NAME=$P(VAL1,"(TITLE 38 ")
  1.  .. ;
  1.  . I $L(VAL1,"ICD-9-CM ")>1 D
  1.  .. S SYS="ICD-9-CM "
  1.  .. S COD=$P($P(VAL1,SYS,2),")")
  1.  .. S:COD["/" COD=$P(COD,"/",1)
  1.  .. S CIEN=+$$CODEN^ICDCODE(COD,80)
  1.  .. S NAME=$P(VAL1," (ICD-9-CM")
  1.  . I $L(NAME)=0 S NAME=$P($P(VAL1," (")," *")
  1.  . ;
  1.  . ; jeh Clean left over codes
  1.  . S NAME=$P(NAME," (CPT-4")
  1.  . S NAME=$P(NAME," (DSM-IV")
  1.  . S NAME=$P(NAME,"(TITLE 38 ")
  1.  . S NAME=$P(NAME," (ICD-9-CM")
  1.  . ;
  1.  . S VAL=NAME_U_COD_U_CIEN_U_SYS ; ien^.01^icd^icdifn^system
  1.  . S LIST(S)=VAL
  1.  . S MAX=S
  1.  I $G(MAX)'="" S LIST(MAX+1)=$G(LEX("MAT"))
  1.  K ^TMP("LEXSCH",$J)
  1.  Q
  1.  ;
  1. ICDREC(COD) ; 
  1.  N CODIEN
  1.  I COD="" Q ""
  1.  S COD=$P($P(COD,U),"/")
  1.  S CODIEN=+$O(^ICD9("AB",COD_" ",0))
  1.  S:CODIEN'>0 CODIEN=+$O(^ICD9("AB",COD_"0 ",0))
  1.  Q CODIEN
  1.  ;Q $O(^ICD9("BA",COD,""))
  1.  ;
  1. CPTREC(COD) ; 
  1.  I COD="" Q ""
  1.  Q $O(^ICPT("BA",COD,""))
  1.  ;
  1. EDLOAD(RETURN,DA,GMPROV,GMPVAMC) ; LOAD  EDIT ARRAYS
  1.  ; DA=problem IFN
  1.  N I,GMPFLD,GMPORIG,GMPL
  1.  D GETFLDS^GMPLEDT3(DA)
  1.  S I=0
  1.  D LOADFLDS(.RETURN,"GMPFLD","NEW",.I)
  1.  D LOADFLDS(.RETURN,"GMPORIG","ORG",.I)
  1.  K GMPFLD,GMPORIG,GMPL  ; should not have to do this
  1.  Q
  1.  ;
  1. LOADFLDS(RETURN,NAM,TYP,I) ; LOAD FIELDS FOR TYPE OF ARRAY
  1.  N S,V,CVP,PN,PID
  1.  S S="",V=$C(254)
  1.  F  S S=$O(@NAM@(S)) Q:S=10  D
  1.  . S RETURN(I)=TYP_V_S_V_@NAM@(S)
  1.  . S I=I+1
  1.  S S=""
  1.  F  S S=$O(@NAM@(10,S)) Q:S=""  D
  1.  . S CVP=@NAM@(10,S)
  1.  . S PN="" ; provider name
  1.  . S PID=$P(CVP,U,6) ; provider id
  1.  . I PID'=""  S PN=$$GET1^DIQ(200,PID,.01) ; get provider name
  1.  . S RETURN(I)=TYP_V_"10,"_S_V_CVP_U_PN
  1.  . S I=I+1
  1.  Q
  1.  ;
  1. EDSAVE(RETURN,GMPIFN,GMPROV,GMPVAMC,UT,EDARRAY) ; SAVE EDITED RES
  1.  ; RETURN - boolean, 1 success, 0 failure
  1.  ; EDARRAY - array used for indirect sets of GMPORIG() and GMPFLDS()
  1.  ;
  1.  N GMPFLD,GMPORIG,S,GMPLUSER
  1.  S RETURN=1 ; initialize for success
  1.  I UT S GMPLUSER=1
  1.  ;
  1.  ;S GMPLUSER=1
  1.  S S=""
  1.  F  S S=$O(EDARRAY(S)) Q:S=""  D
  1.  . S @EDARRAY(S)
  1.  I $D(GMPFLD(10,"NEW"))>9 D  I 'RETURN Q  ; Bail Out if no lock
  1.  . L +^AUPNPROB(GMPIFN,11):10  ; given bogus nature of this lock, should be able to get
  1.  . I '$T S RETURN=0
  1.  ;
  1.  D EN^GMPLSAVE  ; save the data
  1.  K GMPFLD,GMPORIG
  1.  ;
  1.  L -^AUPNPROB(GMPIFN,11)  ; free this instance of lock (in case it was set)
  1.  S RETURN=1
  1.  Q
  1.  ;
  1. UPDATE(ORRETURN,UPDARRAY) ; UPDATE A PROBLEM RECORD
  1.  ; Does essentially same job as EDSAVE above, however does not handle edits to comments
  1.  ; or addition of multiple comments. 
  1.  ; Use initially just for status updates.
  1.  ;
  1.  N S,GMPL,GMPORIG ; last 2 vars created in nested call
  1.  S S=""
  1.  F  S S=$O(UPDARRAY(S)) Q:S=""  D
  1.  . S @UPDARRAY(S)
  1.  D UPDATE^GMPLUTL(.ORARRAY,.ORRETURN)
  1.  K ORARRAY
  1.  ; broker wont pick up root node RETURN
  1.  S ORRETURN(1)=ORRETURN(0) ; error text
  1.  S ORRETURN(0)=ORRETURN ; gmpdfn
  1.  I ORRETURN(0)=""  S ORRETURN=1 ; insurance ? need
  1.  Q
  1.  ;
  1. ADDSAVE(RETURN,GMPDFN,GMPROV,GMPVAMC,ADDARRAY) ; SAVE NEW RECORD
  1.  ; RETURN - Problem IFN if success, 0 otherwise
  1.  ; ADDARRAY - array used for indirect sets of  GMPFLDS()
  1.  ;
  1.  N DA,GMPFLD,GMPORIG,S
  1.  S RETURN=0 ;
  1.  L +^AUPNPROB(0):10
  1.  Q:'$T  ; bail out if no lock
  1.  ;
  1.  S S=""
  1.  F  S S=$O(ADDARRAY(S)) Q:S=""  D
  1.  . S @ADDARRAY(S)
  1.  ;
  1.  D NEW^GMPLSAVE
  1.  ;
  1.  S RETURN=DA
  1.  ;
  1.  L -^AUPNPROB(0)
  1.  S RETURN=1
  1.  Q
  1.  ;
  1. INITUSER(RETURN,ORDUZ) ; INITIALIZE FOR NEW USER
  1.  ; taken from INIT^GMPLMGR
  1.  ; leave GMPLUSER on symbol table - is evaluated in EDITSAVE
  1.  ; 
  1.  N X,PV,CTXT,GMPLPROV
  1.  S GMPLUSER=$$CLINUSER(DUZ)
  1.  S CTXT=$$GET^XPAR("ALL","ORCH CONTEXT PROBLEMS",1)
  1.  S X=$G(^GMPL(125.99,1,0)) ; IN1+6^GMPLMGR
  1.  S RETURN(0)=GMPLUSER ;  problem list user, or other user
  1.  S RETURN(1)=$$VIEW^GMPLX1(DUZ) ; GMPLVIEW("VIEW") - users default view
  1.  S RETURN(2)=+$P(X,U,2) ; verify transcribed problems
  1.  S RETURN(3)=+$P(X,U,3) ; prompt for chart copy
  1.  S RETURN(4)=+$P(X,U,4) ; use lexicon
  1.  S RETURN(5)=$S($P(X,U,5)="R":1,1:0) ; chron or reverse chron listing
  1.  S RETURN(6)=$S($P($G(CTXT),";",3)'="":$P($G(CTXT),";",3),1:"A")
  1.  S GMPLPROV=$P($G(CTXT),";",5)
  1.  I +GMPLPROV>0,$D(^VA(200,GMPLPROV)) D
  1.  . S RETURN(7)=GMPLPROV_U_$P(^VA(200,GMPLPROV,0),U)
  1.  E  S RETURN(7)="0^All"
  1.  S RETURN(8)=$$SERVICE^GMPLX1(DUZ) ; user's service/section
  1.  ; Guessing from what I see in the data that $$VIEW^GMPLX1 actually returns a composite
  1.  ; of default view (in/out patient)/(c1/c2... if out patient i.e. GMPLVIEW("CLIN")) or
  1.  ;                                 /(s1/s2... if in patient i.e. GMPLVIEW("SERV"))
  1.  ; Going with this assumption for now:
  1.  I $L(RETURN(1),"/")>1 D
  1.  . S PV=RETURN(1)
  1.  . S RETURN(1)=$P(PV,"/")
  1.  . I RETURN(1)="C" S GMPLVIEW("CLIN")=$P(PV,"/",2,99)
  1.  . I RETURN(1)="S" S GMPLVIEW("SERV")=$P(PV,"/",2,99)
  1.  S RETURN(9)=$G(GMPLVIEW("SERV")) ; ??? Where from - see tech doc
  1.  S RETURN(10)=$G(GMPLVIEW("CLIN")) ; ??? Where from - see tech doc
  1.  S RETURN(11)=""
  1.  S RETURN(12)=+$P($G(CTXT),";",4)    ; should comments display?
  1.  K GMPLVIEW
  1.  Q
  1.  ;
  1. CLINUSER(ORDUZ) ;is this a clinical user?
  1.  N ORUSER
  1.  S ORUSER=0
  1.  I $D(^XUSEC("ORES",ORDUZ)) S ORUSER=1
  1.  I $D(^XUSEC("ORELSE",ORDUZ)) S ORUSER=1
  1.  I $D(^XUSEC("PROVIDER",ORDUZ)) S ORUSER=1
  1.  Q ORUSER
  1.  ;
  1. INITPT(RETURN,DFN) ; GET PATIENT PARAMETERS
  1.  Q:+$G(DFN)=0
  1.  N GMPSC,GMPAGTOR,GMPION,GMPGULF,GMPHNC,GMPMST,GMPCV,GMPSHD
  1.  ;
  1.  S RETURN(0)=DUZ(2) ; facility #
  1.  D DEM^VADPT ; get death indicator
  1.  S RETURN(1)=$G(VADM(6)) ; death indicator
  1.  D VADPT^GMPLX1(DFN) ; get eligibilities
  1.  S RETURN(2)=$P(GMPSC,U) ; service connected
  1.  S RETURN(3)=$G(GMPAGTOR) ; agent orange exposure
  1.  S RETURN(4)=$G(GMPION) ; ionizing radiation exposure
  1.  S RETURN(5)=$G(GMPGULF) ; gulf war exposure
  1.  S RETURN(6)=VA("BID") ; need this to reconstitute GMPDFN on return
  1.  S RETURN(7)=$G(GMPHNC) ; head/neck cancer
  1.  S RETURN(8)=$G(GMPMST) ; MST
  1.  S RETURN(9)=$G(GMPCV) ; CV
  1.  S RETURN(10)=$G(GMPSHD) ; SHAD
  1.  Q
  1.  ;
  1. PROVSRCH(LST,FLAG,N,FROM,PART) ; Get candidate Rroviders from person file
  1.  N LV,NS,RV,IEN
  1.  S RV=$NAME(LV("DILIST","ID"))
  1.  IF +$G(N)=0 S N=50
  1.  S FLAG=$G(FLAG),N=$G(N),FROM=$G(FROM),PART=$G(PART)
  1.  D LIST^DIC(200,"",".01;1",FLAG,N,FROM,PART,"","","","LV")
  1.  S NS=""
  1.  F  S NS=$O(LV("DILIST",1,NS)) Q:NS=""  D
  1.  . S IEN=""
  1.  . S IEN=$O(^VA(200,"B",@RV@(NS,.01),IEN)) ; compliments of PROV^ORQPTQ
  1.  . S LST(NS)=IEN_U_@RV@(NS,.01)  ; initials_U_@RV@(NS,1)
  1.  Q
  1.  ;
  1. CLINSRCH(Y,X) ; Get LIST OF CLINICS
  1.  ; Note: This comes from CLIN^ORQPTQ2, where it was commented out in place of 
  1.  ; a call to ^XPAR. I would have just used CLIN^ORQPTQ2, but it didn't work - at
  1.  ; least on SLC OEX directory.
  1.  ; X has no purpose other than to satisfy apparent rpc and tcallv requirement for args
  1.  N I,NAME,IEN
  1.  S I=1,IEN=0,NAME=""
  1.  ;access to SC global granted under DBIA #518:
  1.  F  S NAME=$O(^SC("B",NAME)) Q:NAME=""  S IEN=$O(^(NAME,0)) D
  1.  . I $P(^SC(IEN,0),"^",3)="C" S Y(I)=IEN_"^"_NAME,I=I+1
  1.  Q
  1.  ;
  1. SRVCSRCH(Y,FROM,DIR,ALL) ; GET LIST OF SERVICES
  1.  N I,IEN,CNT S I=0,CNT=44
  1.  F  Q:I=CNT  S FROM=$O(^DIC(49,"B",FROM),DIR) Q:FROM=""  D
  1.  . S IEN=$O(^DIC(49,"B",FROM,0)) I '$G(ALL),$P(^DIC(49,IEN,0),U,9)'="C" Q
  1.  . S I=I+1,Y(I)=IEN_"^"_FROM
  1.  Q
  1.  ;
  1. DUP(Y,DFN,TERM,TEXT) ;Check for duplicate problem
  1.  S Y=$$DUPL^GMPLX(DFN,TERM,TEXT) Q:+Y=0
  1.  I $P(^AUPNPROB(Y,1),U,2)="H" S Y=0 Q
  1.  S Y=Y_U_$P(^AUPNPROB(Y,0),U,12)
  1.  Q