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

DGRRLU1.m

Go to the documentation of this file.
  1. DGRRLU1 ;alb/aas - DG Replacement and Rehosting RPC for VADPT ;1/4/06 11:31
  1. ;;5.3;Registration;**538**;Aug 13, 1993
  1. ;
  1. SET X="You Can't Enter DGRRLU1 at top of routine!"
  1. QUIT
  1. ;
  1. BUS(RESULT,PARAMS) ; -- return business logic data for 1 patient in xml format
  1. ; -- RPC: DGRR GET PTLK BUSINESS DATA
  1. ;
  1. ; -- input [required] PARAMS("PATIENT_ID_TYPE") = 'DFN' or 'ICN'
  1. ; [required] PARAMS("PATIENT_ID") = a DFN value or an ICN value
  1. ; [required] PARAMS("USER_ID_TYPE") = 'VPID' or 'DUZ'
  1. ; [required] PARAMS("USER_ID") = value of a VPID, or DUZ
  1. ; [optional] PARAMS("USER_INSTITUTION") = Station # (Defaults to DUZ(2) if not received)
  1. ; [temporary/optional] PARAMS("PATIENT_RECORD_FLAG") = Optional. If 1 the query returns old version of the patient_record_flag business rule
  1. ;
  1. ; -- returns result array that contains XML document containing data for 12 checks of patient
  1. ; related to lookup that is executed in the business layer. See Patient Lookup documentation
  1. ; for logic
  1. ;
  1. NEW X,Y,CNT,DGRRLINE,DGRRESLT,PTID,DGENR,ICN,USERID,INSTTTN,ERRMESS
  1. KILL RESULT,DGRRESLT
  1. SET CNT=0
  1. SET DGRRLINE=0
  1. K ^TMP($J,"PLU-BRULES")
  1. SET DGRRESLT="^TMP($J,""PLU-BRULES"")"
  1. SET RESULT=$NA(@DGRRESLT)
  1. DO DT^DICRW
  1. ;
  1. USER ; establish the DUZ from User ID
  1. IF ($G(PARAMS("USER_ID_TYPE"))="VPID") SET USERID=$$IEN^XUPS($G(PARAMS("USER_ID")))
  1. IF ($G(PARAMS("USER_ID_TYPE"))="DUZ") SET USERID=$G(PARAMS("USER_ID"))
  1. IF +$G(USERID)>0 DO DUZ^XUP(USERID)
  1. IF +$G(USERID)<1 SET ERRMESS="USER_ID_TYPE: "_$G(PARAMS("USER_ID_TYPE"))_" USER_ID: "_$G(PARAMS("USER_ID"))_" does not exist."
  1. ;
  1. INSTTTN ; set institution to USER_INSTITUTION if available else set to default institution
  1. ;USER_INSTITUTION parameter if defined will contain the station number for
  1. ;an institution. Call $$IEN^XUAF4 (IA#2171) to convert station number to IEN.
  1. SET INSTTTN=$G(PARAMS("USER_INSTITUTION")),INSTTTN=$$IEN^XUAF4(INSTTTN)
  1. IF INSTTTN="" S INSTTTN=$G(DUZ(2))
  1. ;
  1. PATIENT ; establish Patient VPID from Patient ID
  1. IF $G(PARAMS("PATIENT_ID_TYPE"))="ICN" DO
  1. .SET ICN=$G(PARAMS("PATIENT_ID"))
  1. .SET PTID=$$CHARCHK^DGRRUTL($$GETDFN^MPIF001($P(ICN,"V",1)))
  1. IF $G(PARAMS("PATIENT_ID_TYPE"))="DFN" DO
  1. .SET PTID=$$CHARCHK^DGRRUTL($GET(PARAMS("PATIENT_ID")))
  1. IF ($G(PTID)<1) SET ERRMESS="PATIENT_ID_TYPE: "_$G(PARAMS("PATIENT_ID_TYPE"))_" PATIENT_ID: "_$G(PARAMS("PATIENT_ID"))_" does not exist."
  1. IF ($G(PTID)>0),($G(^DPT(PTID,0))="") SET ERRMESS="For Patient Id ("_PTID_"), no data exists."
  1. ;
  1. DO ADD^DGRRLU($$XMLHDR^DGRRUTL())
  1. IF ($G(ERRMESS)'="") D ADD^DGRRLU("<error message="_ERRMESS_"'></error>") GOTO BUSEND
  1. DO ADD^DGRRLU("<businessRules patientId='"_PTID_"' patientName='"_$$CHARCHK^DGRRUTL($P($G(^DPT(PTID,0)),"^",1))_"' patientSSN='"_$P($G(^DPT(PTID,0)),"^",9)_"'>")
  1. DO ADD^DGRRLU("<error message=''></error>")
  1. D RULES(PTID,INSTTTN)
  1. BUSEND DO ADD^DGRRLU("</businessRules>")
  1. QUIT
  1. ;
  1. RULES(DFN,DIV) ;
  1. ; -- display order from old SRS
  1. ; Messages will display in the following order:
  1. ; emp SSN mission, Similar, Deceased, Security (sometimes), CWAD, Missing, Test, Enrollment and Means Test.
  1. ;
  1. N DOD,MASPARAM,TPFIELD,SENSITIV,USERKEY,SIM,PTSSN,PRIM1,EMPSSN,PTSSN
  1. SET EMPSSN=$$GET1^DIQ(200,DUZ_",",9,"I","","DGNPERR")
  1. SET PTSSN=$P($G(^DPT(DFN,0)),"^",9)
  1. SET USERKEY=$S($D(^XUSEC("DG RECORD ACCESS",DUZ)):"true",1:"false")
  1. SET MASPARAM=$S(+$P($G(^DG(43,1,"REC")),"^")=1:"true",1:"false") ;Restrict Patient Record Access (#1201)
  1. ;
  1. 0 ; -- employee SSN missing from new person file
  1. N X
  1. S X=" <businessRule alertId='employeeSSNExists' empSsn='"_$$CHARCHK^DGRRUTL(EMPSSN)
  1. S X=X_"' masParameter='"_$$CHARCHK^DGRRUTL(MASPARAM)
  1. S X=X_"' userRecordAccessPrivilege='"_$$CHARCHK^DGRRUTL(USERKEY)_"'></businessRule>"
  1. D ADD^DGRRLU(X)
  1. ;
  1. 1 ; -- similar patients, Checks the BS5 cross reference for similar patients and matches last name
  1. ; bs5 index is first character of last name concatenated with last 4 of ssn.
  1. ; give warning, ask if okay,
  1. ;
  1. SET SIM=$S($$BS5^DPTLK5(DFN)=1:"true",1:"false")
  1. DO ADD^DGRRLU(" <businessRule alertId='similarPatients' similarPatientsFound='"_$$CHARCHK^DGRRUTL(SIM)_"'></businessRule>")
  1. ;
  1. 2 ; -- deceased patient
  1. ; give warning if patient is deceased
  1. SET DOD=$P($G(^DPT(DFN,.35)),"^",1)
  1. DO ADD^DGRRLU(" <businessRule alertId='deceasedPatient' theDateOfDeath='"_$$CHARCHK^DGRRUTL(DOD)_"'></businessRule>")
  1. ;
  1. 3 ; -- accessing own record and user doesn't have dg record access key and MAS parameter to restrict patient records=yes
  1. ; check parameter first, check key second. if (param && !userKey), if (emp ssn == to pt ssn) don't allow (check format of ssn)
  1. ; if (empssn=="") tell them to get added and don't allow access
  1. SET X=" <businessRule alertId='accessOwnRecord' masParameter='"_$$CHARCHK^DGRRUTL(MASPARAM)
  1. SET X=X_"' userRecordAccessPrivilege='"_$$CHARCHK^DGRRUTL(USERKEY)_"' employeeSSN='"_$$CHARCHK^DGRRUTL(EMPSSN)_"' patientSSN='"_$$CHARCHK^DGRRUTL(PTSSN)_"'></businessRule>"
  1. DO ADD^DGRRLU(X)
  1. ;
  1. 4 ; -- primary elig = employee and user doesn't hold dg security office key,from EMPL^DGSEC4(DFN)
  1. ; give message and log if chosen
  1. NEW ELIST,DGELIG
  1. S DGELIG=0,ELIST=""
  1. F S DGELIG=+$O(^DPT("AEL",DFN,DGELIG)) Q:'DGELIG D
  1. . S ELIST=ELIST_$P($G(^DIC(8.1,+$P($G(^DIC(8,DGELIG,0)),"^",9),0)),"^",1)_","
  1. SET USERKEY=$S($D(^XUSEC("DG SECURITY OFFICER",DUZ)):"true",1:"false")
  1. DO ADD^DGRRLU(" <businessRule alertId='patientIsEmployee' eligibilityList='"_$$CHARCHK^DGRRUTL(ELIST)_"' primElig='"_$$CHARCHK^DGRRUTL($$PRIM^DGRRLUA(DFN))_"' userSecurityOfficerPrivilege='"_$$CHARCHK^DGRRUTL(USERKEY)_"'></businessRule>")
  1. ;
  1. 5 ; -- sensitive record and user doesn't have the dg sensitivity key
  1. ; ask to continue, if yes, log if chosen
  1. SET SENSITIV=$S($P($G(^DGSL(38.1,DFN,0)),"^",2)=1:"true",1:"false")
  1. SET USERKEY=$S($D(^XUSEC("DG SENSITIVITY",DUZ)):"true",1:"false")
  1. DO ADD^DGRRLU(" <businessRule alertId='sensitiveRecord' isSensitive='"_$$CHARCHK^DGRRUTL(SENSITIV)_"' userSensitivityPrivilege='"_$$CHARCHK^DGRRUTL(USERKEY)_"'></businessRule>")
  1. ;
  1. 6 ; -- cwad for patient (C)risis notes, Clinical (W)arnings, (A)lergies, and Advance (D)irectives
  1. NEW CWAD
  1. SET CWAD=$$CWAD^ORQPT2(DFN)
  1. DO ADD^DGRRLU(" <businessRule alertId='cwadChecks' cwads='"_$$CHARCHK^DGRRUTL(CWAD)_"'></businessRule>")
  1. ;
  1. 7 ; -- patient on MPR, see if patient is listed in Missing Patient Register
  1. NEW MPREC
  1. ;S X="MPRCHK" X ^%ZOSF("TEST") I $T I $L($T(GUI^MPRCHK)) D GUI^MPRCHK(DFN,.MPREC) ; MPR
  1. DO ADD^DGRRLU(" <businessRule alertId='patientOnMPR' value='"_$$CHARCHK^DGRRUTL($S($G(MPREC(0))=1:"true",1:"false"))_"'></businessRule>")
  1. ;
  1. 8 ; -- test patient
  1. ; if (dataColumn=1) display message.
  1. S TPFIELD="false"
  1. I $$TESTPAT^VADPT(DFN) S TPFIELD="true"
  1. DO ADD^DGRRLU(" <businessRule alertId='testPatient' testPatientColumn='"_$$CHARCHK^DGRRUTL(TPFIELD)_"'></businessRule>")
  1. ;
  1. 9 ; -- enrollment information FROM DPTLK, Provide Enrollment data for user notification
  1. ;
  1. ; If patient is NOT ELIGIBLE, display Enrollment Status (Ineligible Project Phase I)
  1. ; Get Enrollment Group Threshold Priority and Subgroup
  1. ; Compare Patient's Enrollment Priority to Enrollment Group Threshold
  1. ;
  1. NEW ENCAT,ENPRIO,ENSUBGRP,ENEND,LINE,DGENST
  1. S ENCAT=""
  1. I $$GET^DGENA($$FINDCUR^DGENA(+DFN),.DGENR) D
  1. . S ENCAT=$$CATEGORY^DGENA4(+DFN)
  1. . S ENCAT=$$EXTERNAL^DILFD(27.15,.02,"",ENCAT)
  1. S ENPRIO=$S($G(DGENR("PRIORITY")):$$EXT^DGENU("PRIORITY",DGENR("PRIORITY")),1:"")
  1. S ENSUBGRP=$S($G(DGENR("SUBGRP"))="":"",1:$$EXT^DGENU("SUBGRP",$G(DGENR("SUBGRP"))))
  1. SET ENEND=$G(DGENR("END"))
  1. SET DGENST=$S($G(DGENR("STATUS"))=10:DGENR("STATUS"),$G(DGENR("STATUS"))=19:DGENR("STATUS"),$G(DGENR("STATUS"))=20:DGENR("STATUS"),1:"")
  1. I DGENST'="" S DGENST=$$EXTERNAL^DILFD(27.11,.04,"",DGENST)
  1. ; check for Combat Veteran Eligibility, if elig do not display EGT info
  1. N DGENTHR
  1. S DGENTHR=1
  1. I '$$CVEDT^DGCV(+DFN) D
  1. .;Get Enrollment Group Threshold Priority and Subgroup
  1. .N DGEGTIEN,DGEGT
  1. .S DGEGTIEN=$$FINDCUR^DGENEGT
  1. .S DGEGT=$$GET^DGENEGT(DGEGTIEN,.DGEGT)
  1. .Q:$G(DGENR("PRIORITY"))=""!($G(DGEGT("PRIORITY"))="")
  1. .;Compare Patient's Enrollment Priority to Enrollment Group Threshold
  1. .S DGENTHR=$$ABOVE^DGENEGT1(+DFN,DGENR("PRIORITY"),$G(DGENR("SUBGRP")),DGEGT("PRIORITY"),DGEGT("SUBGRP"))
  1. SET LINE=" <businessRule alertId='enrollmentData' category='"_$$CHARCHK^DGRRUTL(ENCAT)_"' endDate='"_$$CHARCHK^DGRRUTL(ENEND)_"' priority='"
  1. SET LINE=LINE_$$CHARCHK^DGRRUTL(ENPRIO)_"' subgroup='"_$$CHARCHK^DGRRUTL(ENSUBGRP)_"' status='"_$$CHARCHK^DGRRUTL(DGENST)
  1. SET LINE=LINE_"' aboveThreshold='"_DGENTHR_"'></businessRule>"
  1. D ADD^DGRRLU(LINE)
  1. ;
  1. D 10^DGRRLU1A
  1. END ;
  1. QUIT