source: WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQQPL1.m@ 1046

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