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

RORX002.m

Go to the documentation of this file. 
  1. RORX002 ;HOIFO/SG,VAC - CURRENT INPATIENT LIST ;4/7/09 2:06pm
  1.  ;;1.5;CLINICAL CASE REGISTRIES;**1,8,19,21,31,32,34,39**;Feb 17, 2006;Build 4
  1.  ;
  1.  ; This routine uses the following IAs:
  1.  ;
  1.  ; #10061        51^VADPT (supported)
  1.  ;
  1.  ; Routine modified March 2009 for ICD9 filter for INCLUDE or EXCLUDE
  1.  ;
  1.  ;******************************************************************************
  1.  ;******************************************************************************
  1.  ;                       --- ROUTINE MODIFICATION LOG ---
  1.  ;        
  1.  ;PKG/PATCH    DATE        DEVELOPER    MODIFICATION
  1.  ;-----------  ----------  -----------  ----------------------------------------
  1.  ;ROR*1.5*19   FEB  2012   K GUPTA      Support for ICD-10 Coding System
  1.  ;ROR*1.5*21   SEP 2013    T KOPP       Add ICN column if Additional Identifier
  1.  ;                                       requested.
  1.  ;ROR*1.5*31   MAY 2017    M FERRARESE  Adding PACT, PCP, and AGE/DOB as additional
  1.  ;                                       identifiers.
  1.  ;ROR*1.5*32   11/07/17    S ALSAHHAR   Add 'Admitting Diagnosis' column
  1.  ;ROR*1.5*34   09/24/18    F TRAXLER    Add 'Admitting Date' column
  1.  ;ROR*1.5*39   JUL 2021    M FERRARESE  Setting SSN and LAST4 to zeros
  1.  ;******************************************************************************
  1.  ;
  1.  Q
  1.  ;
  1.  ;***** OUTPUTS THE REPORT HEADER
  1.  ;
  1.  ; PARTAG        Reference (IEN) to the parent tag
  1.  ;
  1.  ; Return Values:
  1.  ;       <0  Error code
  1.  ;        0  Ok
  1.  ;
  1.  ;;PATIENTS(#,NAME,LAST4,AGE,WARD,ROOM-BED,ADMDT,DIAG,ICN,PACT,PCP)^I $$PARAM^RORTSK01("AGE_RANGE","TYPE")="AGE"
  1.  ;;PATIENTS(#,NAME,LAST4,DOB,WARD,ROOM-BED,ADMDT,DIAG,ICN,PACT,PCP)^I $$PARAM^RORTSK01("AGE_RANGE","TYPE")="DOB"
  1.  ;;PATIENTS(#,NAME,LAST4,WARD,ROOM-BED,ADMDT,DIAG,ICN,PACT,PCP)^I $$PARAM^RORTSK01("AGE_RANGE","TYPE")="ALL"
  1.  ;
  1.  N HEADER,RC
  1.  S HEADER=$$HEADER^RORXU002(.RORTSK,PARTAG)
  1.  Q:HEADER<0 HEADER
  1.  S RC=$$TBLDEF^RORXU002("HEADER^RORX002",HEADER)
  1.  Q $S(RC<0:RC,1:HEADER)
  1.  ;
  1.  ;***** COMPILES THE "CURRENT INPATIENT LIST"
  1.  ; REPORT CODE: 002
  1.  ;
  1.  ; .RORTSK       Task number and task parameters
  1.  ;
  1.  ; Return Values:
  1.  ;       <0  Error code
  1.  ;        0  Ok
  1.  ;
  1. INPTLST(RORTSK) ;
  1.  N RORPTN        ; Number of patients in the registry
  1.  N RORREG        ; Registry IEN
  1.  N RORTMP        ; Closed root of the temporary buffer
  1.  ;
  1.  N BODY,ECNT,INPCNT,RC,REPORT,SFLAGS,TMP
  1.  ;--- Root node of the report
  1.  S REPORT=$$ADDVAL^RORTSK11(RORTSK,"REPORT")
  1.  Q:REPORT<0 REPORT
  1.  ;
  1.  ;--- Get and prepare the report parameters
  1.  S RORREG=$$PARAM^RORTSK01("REGIEN")
  1.  S RC=$$PARAMS^RORXU002(.RORTSK,REPORT,,,.SFLAGS)  Q:RC<0 RC
  1.  ;
  1.  ;--- Initialize constants and variables
  1.  S ECNT=0
  1.  S RORPTN=$$REGSIZE^RORUTL02(+RORREG)  S:RORPTN<0 RORPTN=0
  1.  ;
  1.  ;--- Report header
  1.  S RC=$$HEADER(REPORT)  Q:RC<0 RC
  1.  S RORTMP=$$ALLOC^RORTMP()
  1.  D
  1.  . ;--- Query the registry
  1.  . D TPPSETUP^RORTSK01(50)
  1.  . S RC=$$QUERY(.INPCNT,SFLAGS)
  1.  . I RC  Q:RC<0  S ECNT=ECNT+RC
  1.  . ;--- Generate the list of patients
  1.  . D TPPSETUP^RORTSK01(50)
  1.  . S RC=$$PTLIST(REPORT,INPCNT)
  1.  . I RC  Q:RC<0  S ECNT=ECNT+RC
  1.  ;
  1.  ;--- Cleanup
  1.  D FREE^RORTMP(RORTMP)
  1.  Q $S(RC<0:RC,ECNT>0:-43,1:0)
  1.  ;
  1.  ;***** ADDS THE PATIENT DATA TO THE REPORT
  1.  ;
  1.  ; NODE          Closed root of the patient's node in the buffer
  1.  ; PARTAG        Reference (IEN) to the parent tag
  1.  ;
  1.  ; Return Values:
  1.  ;       <0  Error code
  1.  ;        0  Ok
  1.  ;
  1. PATIENT(NODE,PARTAG) ;
  1.  N IEN,NAME,PATIEN,PTAG,PTBUF,RC,TMP,AGETYPE
  1.  S PTBUF=@NODE,PATIEN=$P(PTBUF,U,2)
  1.  Q:PATIEN'>0 0
  1.  ;--- The <PATIENT> tag
  1.  S PTAG=$$ADDVAL^RORTSK11(RORTSK,"PATIENT",,PARTAG,,PATIEN)
  1.  ;--- Patient data
  1.  D ADDVAL^RORTSK11(RORTSK,"NAME",$QS(NODE,4),PTAG,1)
  1.  D ADDVAL^RORTSK11(RORTSK,"LAST4",$QS(NODE,5),PTAG,2)
  1.  S AGETYPE=$$PARAM^RORTSK01("AGE_RANGE","TYPE") I AGETYPE'="ALL" D
  1.  . D ADDVAL^RORTSK11(RORTSK,$S(AGETYPE="AGE":"AGE",1:"DOB"),$P(PTBUF,U,8),PTAG,1)
  1.  S TMP=$$DATE^RORXU002($P(PTBUF,U,4)\1)
  1.  ;D ADDVAL^RORTSK11(RORTSK,"DOD",TMP,PTAG,1)
  1.  ;
  1.  D ADDVAL^RORTSK11(RORTSK,"WARD",$QS(NODE,3),PTAG,1)
  1.  D ADDVAL^RORTSK11(RORTSK,"ROOM-BED",$P(PTBUF,U,3),PTAG,1)
  1.  D ADDVAL^RORTSK11(RORTSK,"ADMDT",$P(PTBUF,U,10),PTAG,1) ;patch 34
  1.  D ADDVAL^RORTSK11(RORTSK,"DIAG",$P(PTBUF,U,9),PTAG,1)
  1.  ; --- ICN, PACT, PCP if selected will be one of the last columns on report accordingly.
  1.  I $$PARAM^RORTSK01("PATIENTS","ICN") D ADDVAL^RORTSK11(RORTSK,"ICN",$P(PTBUF,U,5),PTAG,1)
  1.  I $$PARAM^RORTSK01("PATIENTS","PACT") D ADDVAL^RORTSK11(RORTSK,"PACT",$P(PTBUF,U,6),PTAG,1)
  1.  I $$PARAM^RORTSK01("PATIENTS","PCP") D ADDVAL^RORTSK11(RORTSK,"PCP",$P(PTBUF,U,7),PTAG,1)
  1.  Q 0
  1.  ;
  1.  ;***** GENERATES THE LIST OF PATIENTS
  1.  ;
  1.  ; REPORT        IEN of the <REPORT> node
  1.  ; INPCNT        Number of inpatients
  1.  ;
  1.  ; Return Values:
  1.  ;       <0  Error code
  1.  ;        0  Ok
  1.  ;       >0  Number of non-fatal errors
  1.  ;
  1. PTLIST(REPORT,INPCNT) ;
  1.  N BODY,CNT,ECNT,FLT,FLTLEN,NODE,RC,TCNT,TMP
  1.  S (CNT,ECNT,RC)=0
  1.  S BODY=$$ADDVAL^RORTSK11(RORTSK,"PATIENTS",,REPORT)
  1.  Q:BODY<0 BODY
  1.  D ADDATTR^RORTSK11(RORTSK,BODY,"TABLE","PATIENTS")
  1.  D:$D(@RORTMP)>1
  1.  . S $P(NODE,U,5)="0000"
  1.  . S NODE=RORTMP
  1.  . S FLTLEN=$L(NODE)-1,FLT=$E(NODE,1,FLTLEN)
  1.  . F  S NODE=$Q(@NODE)  Q:$E(NODE,1,FLTLEN)'=FLT  D  Q:RC<0
  1.  . . S TMP=$S(INPCNT>0:CNT/INPCNT,1:"")
  1.  . . S RC=$$LOOP^RORTSK01(TMP)  Q:RC<0
  1.  . . S CNT=CNT+1
  1.  . . I $$PATIENT(NODE,BODY)<0  S ECNT=ECNT+1  Q
  1.  Q $S(RC<0:RC,1:ECNT)
  1.  ;
  1.  ;***** QUERIES THE REGISTRY
  1.  ;
  1.  ; .INPCNT       Number of inpatients is returned in this parameter
  1.  ; SFLAGS        Flags for $$SKIP^RORXU005
  1.  ;
  1.  ; Return Values:
  1.  ;       <0  Error code
  1.  ;        0  Ok
  1.  ;       >0  Number of non-fatal errors
  1.  ;
  1. QUERY(INPCNT,SFLAGS) ;
  1.  N CNT,DFN,ECNT,IEN,IENS,RC,TCNT,TMP,VA,VADM,VAHOW,VAIP,VAROOT,XREFNODE,WARD,AGEDOB
  1.  N RCC,FLAG
  1.  S XREFNODE=$NA(^RORDATA(798,"AC",+RORREG))
  1.  S (CNT,ECNT,INPCNT,RC)=0
  1.  ;--- Browse through the registry records
  1.  S IEN=0
  1.  S FLAG=$G(RORTSK("PARAMS","ICDFILT","A","FILTER"))
  1.  F  S IEN=$O(@XREFNODE@(IEN))  Q:IEN'>0  D  Q:RC<0
  1.  . S TMP=$S(RORPTN>0:CNT/RORPTN,1:"")
  1.  . S RC=$$LOOP^RORTSK01(TMP)  Q:RC<0
  1.  . S IENS=IEN_",",CNT=CNT+1
  1.  . ;--- Skip a patient
  1.  . Q:$$SKIP^RORXU005(IEN,SFLAGS)
  1.  . ;--- Process the registry record
  1.  . S DFN=$$PTIEN^RORUTL01(IEN)  Q:DFN'>0
  1.  .; --- Check the ICD filter
  1.  . S RCC=0
  1.  . I FLAG'="ALL" D
  1.  . . S RCC=$$ICD^RORXU010(DFN)
  1.  . I (FLAG="INCLUDE")&(RCC=0) Q
  1.  . I (FLAG="EXCLUDE")&(RCC=1) Q
  1.  .;--- End of ICD Filter check
  1.  . K VA,VADM,VAIP,VAIN S VAIP("D")=DT\1 D 51^VADPT
  1.  . D INP^VADPT
  1.  . S AGEDOB=$$PARAM^RORTSK01("AGE_RANGE","TYPE") S AGEDOB=$S(AGEDOB="AGE":$P($G(VADM(4)),U),AGEDOB="DOB":$P($G(VADM(3)),U),1:"")
  1.  . S WARD=$P(VAIP(5),U,2)  Q:WARD=""
  1.  . S VA("BID")="0000" S TMP=$S($G(VA("BID"))'="":VA("BID"),1:"UNKN") ; Last 4 of SSN
  1.  . S @RORTMP@(WARD,VADM(1),TMP)=IEN_U_DFN_U_$P(VAIP(6),U,2)_U_$P(VADM(6),U)
  1.  . S @RORTMP@(WARD,VADM(1),TMP)=@RORTMP@(WARD,VADM(1),TMP)_U_$$ICN^RORUTL02(DFN)
  1.  . S @RORTMP@(WARD,VADM(1),TMP)=@RORTMP@(WARD,VADM(1),TMP)_U_$$PACT^RORUTL02(DFN)
  1.  . S @RORTMP@(WARD,VADM(1),TMP)=@RORTMP@(WARD,VADM(1),TMP)_U_$$PCP^RORUTL02(DFN)
  1.  . S @RORTMP@(WARD,VADM(1),TMP)=@RORTMP@(WARD,VADM(1),TMP)_U_$$DATE^RORXU002(AGEDOB\1)
  1.  . S @RORTMP@(WARD,VADM(1),TMP)=@RORTMP@(WARD,VADM(1),TMP)_U_VAIN(9)
  1.  . S @RORTMP@(WARD,VADM(1),TMP)=@RORTMP@(WARD,VADM(1),TMP)_U_$P($P($G(VAIN(7)),U,1),".",1) ;adm date patch 34
  1.  . S INPCNT=INPCNT+1
  1.  ;---
  1.  Q $S(RC<0:RC,1:ECNT)
  1.  ;
  1.  ;***** CHECKS THE SUFFIX FOR VALIDITY
  1.  ;
  1.  ; SUFFIX        Suffix
  1.  ;
  1.  ; Return Values:
  1.  ;        0  Ok
  1.  ;        1  Invalid suffix
  1. VSUFFIX(SUFFIX) ;
  1.  Q '("9AA,9AB,9BB,A0,A4,A5,BU,BV,PA"[SUFFIX)