PXRMPDEM ;SLC/PKR - Computed findings for patient demographics. ;02/28/2022
;;2.0;CLINICAL REMINDERS;**5,4,11,12,17,18,24,47,42,78**;Feb 04, 2005;Build 10
;
;DBIA USED
;10061 DEM^VADPT
;10035 $P(^DPT(DFN,0),U,3)
;10060 ^VA(200)
;1372 ^DGPT
;1378 ^DGPM
;======================================================
AGE(DFN,TEST,DATE,VALUE,TEXT) ;Computed finding for returning a patient's
;age
S DATE=$$NOW^PXRMDATE,TEST=1
I $D(PXRMPDEM) D Q
. S VALUE=PXRMPDEM("AGE")
. I +PXRMPDEM("DOD")=0 S VALUE("DECEASED")=0 Q
. I +PXRMPDEM("DOD")>0 S VALUE("DECEASED")=1,TEXT="Patient is deceased"
I '$D(PXRMPDEM) D
. N DOB,DOD
.;DBIA #10035
. S DOB=$P(^DPT(DFN,0),U,3)
. S DOD=$P($G(^DPT(DFN,.35)),U,1)
. S VALUE=$$AGE^PXRMAGE(DOB,DOD,$$NOW^PXRMDATE)
. I +DOD=0 S VALUE("DECEASED")=0 Q
. I +DOD>0 S VALUE("DECEASED")=1,TEXT="Patient is deceased"
Q
;
;======================================================
DFA(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,VALUE,TEXT) ;This computed finding
;returns the date the patient turns a specified age. Based on
;work by AJM: 9/16/08.
;DBIA #10035 DATE OF BIRTH is a required field.
I TEST="" S NFOUND=0,DATE(1)=$$NOW^PXRMDATE,TEST(1)=0 Q
S TEST=$P(TEST,".",1)
N BDAY,DOB,YEAR,YOB
S NFOUND=1
S DOB=$S($D(PXRMDOB):PXRMDOB,1:$P(^DPT(DFN,0),U,3))
S YOB=$E(DOB,1,3)
S BDAY=$E(DOB,4,7)
S YEAR=YOB+TEST
I BDAY="0229",'$$ISLEAP^PXRMDATE(YEAR) S BDAY="0228"
S (DATE(1),VALUE(1,"VALUE"))=YEAR_BDAY
S TEST(1)=1
S TEXT(1)="Patient "_$S(DATE(1)>$$NOW^PXRMDATE:"will be ",1:"was ")_+TEST_" years old on "_$$FMTE^XLFDT(DATE(1),"5Z")
Q
;
;======================================================
DOB(DFN,TEST,DATE,VALUE,TEXT) ;Computed finding for a patient's
;date of birth.
I $D(PXRMPDEM) S VALUE=PXRMPDEM("DOB")
;DBIA #10035 DATE OF BIRTH is a required field.
I '$D(PXRMPDEM) S VALUE=$P(^DPT(DFN,0),U,3)
S TEST=$S(VALUE<$$NOW^PXRMDATE:1,1:0)
I TEST S DATE=VALUE,TEXT=$$EDATE^PXRMDATE(VALUE)
Q
;
;======================================================
DOD(DFN,TEST,DATE,VALUE,TEXT) ;Computed finding for a patient's
;date of death.
I $D(PXRMPDEM) S VALUE=+PXRMPDEM("DOD")
;DBIA #10035
I '$D(PXRMPDEM) S VALUE=+$P($G(^DPT(DFN,.35)),U,1)
S TEST=$S(VALUE=0:0,VALUE>$$NOW^PXRMDATE:0,1:1)
I TEST S DATE=VALUE,TEXT=$$EDATE^PXRMDATE(VALUE)
Q
;
;======================================================
EMPLOYE(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,VALUE,TEXT) ;This computed finding
;will return true if the patient is an employee.
;DBIA #10035, #10060
N EDATE,IEN,PAID,SSN,TDATE
S NFOUND=0,DATE(1)=$$NOW^PXRMDATE,TEST(1)=0
S SSN=$P($G(^DPT(DFN,0)),U,9)
I SSN="" Q
;Use SSN to make the link to file #200.
S IEN=+$O(^VA(200,"SSN",SSN,""))
I IEN=0 Q
S PAID=+$P($G(^VA(200,IEN,450)),U,1)
I PAID=0 Q
;Get the entered date.
S EDATE=+$P(^VA(200,IEN,1),U,7)
S VALUE(1,"DATE ENTERED")=EDATE
I (EDATE=0)!(EDATE>EDT) Q
;Check for a termination date.
S TDATE=+$P(^VA(200,IEN,0),U,11)
S VALUE(1,"TERMINATION DATE")=TDATE
I (TDATE>0),(TDATE<BDT) Q
S NFOUND=1,TEST(1)=1,TEXT(1)="Patient is an employee."
Q
;
;======================================================
ETHNY(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,VALUE,TEXT) ;Computed finding for
;a patient's ethnicity.
N CNT,CNT1,VADM
D DEM^VADPT
I $D(VADM(11))'=11 S NFOUND=0 D KVA^VADPT Q
S NGET=$S(NGET<0:-NGET,1:NGET)
S (CNT,CNT1)=0
F S CNT=$O(VADM(11,CNT)) Q:(CNT="")!(CNT1=NGET) D
. S CNT1=CNT1+1,TEST(CNT1)=1,DATE(CNT1)=$$NOW^PXRMDATE
. S TEXT(CNT1)="",VALUE(CNT1,"VALUE")=$P($G(VADM(11,CNT)),U,2)
S NFOUND=CNT1
D KVA^VADPT
Q
;
;======================================================
HDISCH(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;Computed finding for
;a list of a patient's discharge dates from PTF.
;References to ^DGPT covered by DBIA #1372.
N DAS,DDATE,DDATEL,DONE,FEEBASIS,IEN,IND,INCEN,INFEE,NF,SDIR,TEMP,TYPE
S TEMP=$$UP^XLFSTR(TEST)
S TEMP=$P(TEMP,"IN:",2)
S INFEE=$S(TEMP["FEE":1,1:0)
S INCEN=$S(TEMP["CEN":1,1:0)
S IEN="",NFOUND=0
F S IEN=$O(^DGPT("B",DFN,IEN)) Q:IEN="" D
. S DDATE=+$P($G(^DGPT(IEN,70)),U,1)
. I DDATE>0,DDATE'<BDT,DDATE'>EDT S NFOUND=NFOUND+1,DDATEL(DDATE,NFOUND)=^DGPT(IEN,0)
I NFOUND=0 Q
S SDIR=$S(NGET<0:1,1:-1)
S NGET=$S(NGET<0:-NGET,1:NGET)
S (DONE,NF)=0
S DDATE=""
F IND=1:1:NFOUND Q:DONE D
. S DDATE=$O(DDATEL(DDATE),SDIR)
. I DDATE="" S DONE=1 Q
. S IEN=0
. F S IEN=$O(DDATEL(DDATE,IEN)) Q:(IEN="")!(DONE) D
.. S FEEBASIS=$P(DDATEL(DDATE,IEN),U,4)
.. I FEEBASIS=1,'INFEE Q
..;Type 1 is PTF, Type 2 is Census
.. S TYPE=$P(DDATEL(DDATE,IEN),U,11)
.. I TYPE=2,'INCEN Q
.. S NF=NF+1
.. S TEST(NF)=1,(DATE(NF),VALUE(NF))=DDATE
.. I FEEBASIS=1 S TEXT(NF)="Fee basis"
.. I TYPE=2 S TEXT(NF)="Census"
.. I NF=NGET S DONE=1
S NFOUND=NF
Q
;
;======================================================
INP(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,VALUE,TEXT) ;Computed finding for
;determining if a patient is an inpatient on the evaluation date.
N VAIN,VAINDT
S NFOUND=1
S (DATE(1),VAINDT)=$$NOW^PXRMDATE
D INP^VADPT
I VAIN(1)="" S TEST(1)=0 D KVAR^VADPT Q
S TEST(1)=1
S VALUE(1,"PRIMARY PROVIDER")=$P(VAIN(2),U,2)
S VALUE(1,"TREATING SPECIALTY")=$P(VAIN(3),U,2)
S VALUE(1,"WARD LOCATION")=$P(VAIN(4),U,2)
S VALUE(1,"ADMISSION DATE/TIME")=$P(VAIN(7),U,1)
S VALUE(1,"ADMISSION TYPE")=$P(VAIN(8),U,2)
S VALUE(1,"ATTENDING PHYSICIAN")=$P(VAIN(11),U,2)
S TEXT(1)="Patient is an inpatient; admission date/time: "_$$FMTE^XLFDT(VALUE(1,"ADMISSION DATE/TIME"),"5Z")
D KVAR^VADPT
Q
;
;======================================================
NEWRACE(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,VALUE,TEXT) ;Computed finding
;for returning a patient's multi-valued race.
N IND,VADM
D DEM^VADPT
S NFOUND=VADM(12)
I NFOUND=0 D KVA^VADPT Q
S NGET=$S(NGET<0:-NGET,1:NGET)
I NFOUND>NGET S NFOUND=NGET
F IND=1:1:NFOUND D
. S TEST(IND)=1,DATE(IND)=$$NOW^PXRMDATE,TEXT(IND)=""
. S (VALUE(IND,"VALUE"),VALUE(IND,"RACE"))=$P(VADM(12,IND),U,2)
D KVA^VADPT
Q
;
;======================================================
PATTYPE(DFN,TEST,DATE,VALUE,TEXT) ;Computed finding to return the patient
;type
N VAEL
S VALUE=""
S DATE=$$NOW^PXRMDATE
D ELIG^VADPT
S TEST=$S($G(VAEL(6))'="":1,1:0)
S VALUE=$P(VAEL(6),U,2)
D KVAR^VADPT
Q
;
;======================================================
RACE(DFN,TEST,DATE,VALUE,TEXT) ;Computed finding for checking a patient's race.
N RACE
S DATE=$$NOW^PXRMDATE
;DBIA #10035
S RACE=$P($G(^DPT(DFN,0)),U,6)
I RACE="" S TEST=0,VALUE="" Q
Q
;
;======================================================
SEX(DFN,TEST,DATE,VALUE,TEXT) ;Computed finding for returning a patient's
;sex.
S DATE=$$NOW^PXRMDATE,TEST=1
I $D(PXRMPDEM) S VALUE=PXRMPDEM("SEX") Q
;DBIA #10035 SEX is a required field.
I '$D(PXRMPDEM) S VALUE=$P(^DPT(DFN,0),U,2)
Q
;
SEXOR(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,VALUE,TEXT) ;
N ARRAY,IDX,CNT,SDIR,SOSTATUS,SO,SOTYPE,TMPDATE,VADM
D DEM^VADPT
S SOSTATUS=$G(TEST),NFOUND=0
;collect data from file 2
S IDX=0 F S IDX=$O(VADM(14,1,IDX)) Q:IDX'>0 D
.I SOSTATUS'="",SOSTATUS'=$P(VADM(14,1,IDX,1),U) Q
.S SO=$P(VADM(14,1,IDX),U),SOTYPE=$P(VADM(14,1,IDX),U,2)
.S TMPDATE=$S(+$P(VADM(14,1,IDX,3),U,2)>0:$P(VADM(14,1,IDX,3),U,2),1:$P(VADM(14,1,IDX,2),U,2))
.I TMPDATE<BDT Q
.I TMPDATE>EDT Q
.S ARRAY(TMPDATE)=""
.S ARRAY(TMPDATE,IDX,"SEXUAL ORIENTATION")=SO
.S ARRAY(TMPDATE,IDX,"SEXUAL ORIENTATION TYPE CODE")=SOTYPE
.S ARRAY(TMPDATE,IDX,"SO STATUS")=$P(VADM(14,1,IDX,1),U)
;handle return based off positive or negative NGET value
S SDIR=$S(NGET<0:+1,1:-1)
S TMPDATE=""
F S TMPDATE=$O(ARRAY(TMPDATE),SDIR) Q:TMPDATE="" D
.S NFOUND=NFOUND+1 I NFOUND>NGET Q
.S DATE(NFOUND)=TMPDATE,TEST(NFOUND)=1
.S VALUE(NFOUND,"SEXUAL ORIENTATION DAS")=DFN
.S TEXT(NFOUND)="List of sexual orientation:"
.S IDX=0,CNT=0 F S IDX=$O(ARRAY(TMPDATE,IDX)) Q:IDX'>0 D
..S VALUE(NFOUND,"SEXUAL ORIENTATION",IDX)=ARRAY(TMPDATE,IDX,"SEXUAL ORIENTATION")
..S VALUE(NFOUND,"SEXUAL ORIENTATION TYPE CODE",IDX)=ARRAY(TMPDATE,IDX,"SEXUAL ORIENTATION TYPE CODE")
..S CNT=CNT+1,TEXT(NFOUND,CNT)=" "_VALUE(NFOUND,"SEXUAL ORIENTATION",IDX)
..I VALUE(NFOUND,"SEXUAL ORIENTATION",IDX)="Another Option, please describe",$G(VADM(14,2))'="" D
...S VALUE(NFOUND,"OTHER DESCRIPTION")=VADM(14,2)
...S CNT=CNT+1,TEXT(NFOUND,CNT)=" Description: "_VALUE(NFOUND,"OTHER DESCRIPTION")
..S VALUE(NFOUND,"SO STATUS",IDX)=ARRAY(TMPDATE,IDX,"SO STATUS")
..S VALUE(NFOUND,"DIALOG")=1,VALUE(NFOUND,"PACKAGE")="REGISTRATION",VALUE(NFOUND,"PACKAGE PREFIX")="DG"
Q
;
;======================================================
WASINP(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,VALUE,TEXT) ;Computed finding for
;determining if a patient was an inpatient in the period defined
;by BDT and EDT.
;Access to DGPM covered by DBIA #1378
N ADATE,ADM,ADML,AWARD,DDATE,DWARD,IEN,INDT,FDATE,LOS,NOCC,SDIR,TEMP
S FDATE=$S(TEST="DISCH":"DISCH",1:"ADM")
S SDIR=$S(NGET<0:1,1:-1)
S NOCC=$S(NGET<0:-NGET,1:NGET)
S NFOUND=0
;Use the "ATID3" index to build a list of past admissions and
;discharges.
S INDT=""
F S INDT=$O(^DGPM("ATID3",DFN,INDT)) Q:INDT="" D
. S IEN=$O(^DGPM("ATID3",DFN,INDT,""))
. S TEMP=^DGPM(IEN,0)
. S DDATE=$P(TEMP,U,1)
. S ADM=$P(TEMP,U,14)
. S ADATE=$P(^DGPM(ADM,0),U,1)
. I $$OVERLAP^PXRMINDX(ADATE,DDATE,BDT,EDT)'="O" Q
. S AWARD=$$GET1^DIQ(405,ADM,.06),DWARD=$$GET1^DIQ(405,IEN,200)
. S ADML(ADATE)=DDATE_U_AWARD_U_DWARD
;Check for the last admission and add it if it is not on the list.
S INDT=$O(^DGPM("ATID1",DFN,""))
I INDT'="" D
. S IEN=$O(^DGPM("ATID1",DFN,INDT,""))
. S TEMP=^DGPM(IEN,0)
. S ADATE=$P(TEMP,U,1),AWARD=$$GET1^DIQ(405,IEN,.06)
. I $D(ADML(ADATE)) Q
. S IEN=$P(TEMP,U,17)
.;Since this is the last admission there may not be a discharge.
. S DDATE=$S(IEN="":$$NOW^PXRMDATE,1:$P(^DGPM(IEN,0),U,1))
. I $$OVERLAP^PXRMINDX(ADATE,DDATE,BDT,EDT)="O" D
.. S DWARD=$S(IEN="":"",1:$$GET1^DIQ(405,IEN,200))
.. S ADML(ADATE)=DDATE_U_AWARD_U_DWARD
;Sort the list.
S ADATE=""
F S ADATE=$O(ADML(ADATE),SDIR) Q:(NFOUND=NOCC)!(ADATE="") D
. S NFOUND=NFOUND+1,TEST(NFOUND)=1
. S DDATE=$P(ADML(ADATE),U,1),AWARD=$P(ADML(ADATE),U,2),DWARD=$P(ADML(ADATE),U,3)
. I DDATE="" S DDATE=PXRMDATE
. S DATE(NFOUND)=$S(FDATE="DISCH":DDATE,1:ADATE)
. S LOS=$$FMDIFF^XLFDT(DDATE,ADATE)
. S TEMP="Inpatient from: "_$$FMTE^XLFDT(ADATE,"5Z")_" to "
. S TEMP=TEMP_$S(DDATE=PXRMDATE:"now",1:$$FMTE^XLFDT(DDATE,"5Z"))
. S TEMP=TEMP_"; Length of stay "_LOS_" days"
. S TEMP=TEMP_"; Admission ward: "_AWARD
. I DWARD'="" S TEMP=TEMP_"; Discharge ward: "_DWARD
. S TEXT(NFOUND)=TEMP
. S VALUE(NFOUND,"ADMISSION DATE")=ADATE
. S VALUE(NFOUND,"ADMISSION WARD")=AWARD
. S VALUE(NFOUND,"DISCHARGE DATE")=DDATE
. S VALUE(NFOUND,"DISCHARGE WARD")=DWARD
. S VALUE(NFOUND,"LENGTH OF STAY")=LOS
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMPDEM 11072 printed Nov 22, 2024@16:58:37 Page 2
PXRMPDEM ;SLC/PKR - Computed findings for patient demographics. ;02/28/2022
+1 ;;2.0;CLINICAL REMINDERS;**5,4,11,12,17,18,24,47,42,78**;Feb 04, 2005;Build 10
+2 ;
+3 ;DBIA USED
+4 ;10061 DEM^VADPT
+5 ;10035 $P(^DPT(DFN,0),U,3)
+6 ;10060 ^VA(200)
+7 ;1372 ^DGPT
+8 ;1378 ^DGPM
+9 ;======================================================
AGE(DFN,TEST,DATE,VALUE,TEXT) ;Computed finding for returning a patient's
+1 ;age
+2 SET DATE=$$NOW^PXRMDATE
SET TEST=1
+3 IF $DATA(PXRMPDEM)
Begin DoDot:1
+4 SET VALUE=PXRMPDEM("AGE")
+5 IF +PXRMPDEM("DOD")=0
SET VALUE("DECEASED")=0
QUIT
+6 IF +PXRMPDEM("DOD")>0
SET VALUE("DECEASED")=1
SET TEXT="Patient is deceased"
End DoDot:1
QUIT
+7 IF '$DATA(PXRMPDEM)
Begin DoDot:1
+8 NEW DOB,DOD
+9 ;DBIA #10035
+10 SET DOB=$PIECE(^DPT(DFN,0),U,3)
+11 SET DOD=$PIECE($GET(^DPT(DFN,.35)),U,1)
+12 SET VALUE=$$AGE^PXRMAGE(DOB,DOD,$$NOW^PXRMDATE)
+13 IF +DOD=0
SET VALUE("DECEASED")=0
QUIT
+14 IF +DOD>0
SET VALUE("DECEASED")=1
SET TEXT="Patient is deceased"
End DoDot:1
+15 QUIT
+16 ;
+17 ;======================================================
DFA(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,VALUE,TEXT) ;This computed finding
+1 ;returns the date the patient turns a specified age. Based on
+2 ;work by AJM: 9/16/08.
+3 ;DBIA #10035 DATE OF BIRTH is a required field.
+4 IF TEST=""
SET NFOUND=0
SET DATE(1)=$$NOW^PXRMDATE
SET TEST(1)=0
QUIT
+5 SET TEST=$PIECE(TEST,".",1)
+6 NEW BDAY,DOB,YEAR,YOB
+7 SET NFOUND=1
+8 SET DOB=$SELECT($DATA(PXRMDOB):PXRMDOB,1:$PIECE(^DPT(DFN,0),U,3))
+9 SET YOB=$EXTRACT(DOB,1,3)
+10 SET BDAY=$EXTRACT(DOB,4,7)
+11 SET YEAR=YOB+TEST
+12 IF BDAY="0229"
IF '$$ISLEAP^PXRMDATE(YEAR)
SET BDAY="0228"
+13 SET (DATE(1),VALUE(1,"VALUE"))=YEAR_BDAY
+14 SET TEST(1)=1
+15 SET TEXT(1)="Patient "_$SELECT(DATE(1)>$$NOW^PXRMDATE:"will be ",1:"was ")_+TEST_" years old on "_$$FMTE^XLFDT(DATE(1),"5Z")
+16 QUIT
+17 ;
+18 ;======================================================
DOB(DFN,TEST,DATE,VALUE,TEXT) ;Computed finding for a patient's
+1 ;date of birth.
+2 IF $DATA(PXRMPDEM)
SET VALUE=PXRMPDEM("DOB")
+3 ;DBIA #10035 DATE OF BIRTH is a required field.
+4 IF '$DATA(PXRMPDEM)
SET VALUE=$PIECE(^DPT(DFN,0),U,3)
+5 SET TEST=$SELECT(VALUE<$$NOW^PXRMDATE:1,1:0)
+6 IF TEST
SET DATE=VALUE
SET TEXT=$$EDATE^PXRMDATE(VALUE)
+7 QUIT
+8 ;
+9 ;======================================================
DOD(DFN,TEST,DATE,VALUE,TEXT) ;Computed finding for a patient's
+1 ;date of death.
+2 IF $DATA(PXRMPDEM)
SET VALUE=+PXRMPDEM("DOD")
+3 ;DBIA #10035
+4 IF '$DATA(PXRMPDEM)
SET VALUE=+$PIECE($GET(^DPT(DFN,.35)),U,1)
+5 SET TEST=$SELECT(VALUE=0:0,VALUE>$$NOW^PXRMDATE:0,1:1)
+6 IF TEST
SET DATE=VALUE
SET TEXT=$$EDATE^PXRMDATE(VALUE)
+7 QUIT
+8 ;
+9 ;======================================================
EMPLOYE(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,VALUE,TEXT) ;This computed finding
+1 ;will return true if the patient is an employee.
+2 ;DBIA #10035, #10060
+3 NEW EDATE,IEN,PAID,SSN,TDATE
+4 SET NFOUND=0
SET DATE(1)=$$NOW^PXRMDATE
SET TEST(1)=0
+5 SET SSN=$PIECE($GET(^DPT(DFN,0)),U,9)
+6 IF SSN=""
QUIT
+7 ;Use SSN to make the link to file #200.
+8 SET IEN=+$ORDER(^VA(200,"SSN",SSN,""))
+9 IF IEN=0
QUIT
+10 SET PAID=+$PIECE($GET(^VA(200,IEN,450)),U,1)
+11 IF PAID=0
QUIT
+12 ;Get the entered date.
+13 SET EDATE=+$PIECE(^VA(200,IEN,1),U,7)
+14 SET VALUE(1,"DATE ENTERED")=EDATE
+15 IF (EDATE=0)!(EDATE>EDT)
QUIT
+16 ;Check for a termination date.
+17 SET TDATE=+$PIECE(^VA(200,IEN,0),U,11)
+18 SET VALUE(1,"TERMINATION DATE")=TDATE
+19 IF (TDATE>0)
IF (TDATE<BDT)
QUIT
+20 SET NFOUND=1
SET TEST(1)=1
SET TEXT(1)="Patient is an employee."
+21 QUIT
+22 ;
+23 ;======================================================
ETHNY(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,VALUE,TEXT) ;Computed finding for
+1 ;a patient's ethnicity.
+2 NEW CNT,CNT1,VADM
+3 DO DEM^VADPT
+4 IF $DATA(VADM(11))'=11
SET NFOUND=0
DO KVA^VADPT
QUIT
+5 SET NGET=$SELECT(NGET<0:-NGET,1:NGET)
+6 SET (CNT,CNT1)=0
+7 FOR
SET CNT=$ORDER(VADM(11,CNT))
if (CNT="")!(CNT1=NGET)
QUIT
Begin DoDot:1
+8 SET CNT1=CNT1+1
SET TEST(CNT1)=1
SET DATE(CNT1)=$$NOW^PXRMDATE
+9 SET TEXT(CNT1)=""
SET VALUE(CNT1,"VALUE")=$PIECE($GET(VADM(11,CNT)),U,2)
End DoDot:1
+10 SET NFOUND=CNT1
+11 DO KVA^VADPT
+12 QUIT
+13 ;
+14 ;======================================================
HDISCH(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;Computed finding for
+1 ;a list of a patient's discharge dates from PTF.
+2 ;References to ^DGPT covered by DBIA #1372.
+3 NEW DAS,DDATE,DDATEL,DONE,FEEBASIS,IEN,IND,INCEN,INFEE,NF,SDIR,TEMP,TYPE
+4 SET TEMP=$$UP^XLFSTR(TEST)
+5 SET TEMP=$PIECE(TEMP,"IN:",2)
+6 SET INFEE=$SELECT(TEMP["FEE":1,1:0)
+7 SET INCEN=$SELECT(TEMP["CEN":1,1:0)
+8 SET IEN=""
SET NFOUND=0
+9 FOR
SET IEN=$ORDER(^DGPT("B",DFN,IEN))
if IEN=""
QUIT
Begin DoDot:1
+10 SET DDATE=+$PIECE($GET(^DGPT(IEN,70)),U,1)
+11 IF DDATE>0
IF DDATE'<BDT
IF DDATE'>EDT
SET NFOUND=NFOUND+1
SET DDATEL(DDATE,NFOUND)=^DGPT(IEN,0)
End DoDot:1
+12 IF NFOUND=0
QUIT
+13 SET SDIR=$SELECT(NGET<0:1,1:-1)
+14 SET NGET=$SELECT(NGET<0:-NGET,1:NGET)
+15 SET (DONE,NF)=0
+16 SET DDATE=""
+17 FOR IND=1:1:NFOUND
if DONE
QUIT
Begin DoDot:1
+18 SET DDATE=$ORDER(DDATEL(DDATE),SDIR)
+19 IF DDATE=""
SET DONE=1
QUIT
+20 SET IEN=0
+21 FOR
SET IEN=$ORDER(DDATEL(DDATE,IEN))
if (IEN="")!(DONE)
QUIT
Begin DoDot:2
+22 SET FEEBASIS=$PIECE(DDATEL(DDATE,IEN),U,4)
+23 IF FEEBASIS=1
IF 'INFEE
QUIT
+24 ;Type 1 is PTF, Type 2 is Census
+25 SET TYPE=$PIECE(DDATEL(DDATE,IEN),U,11)
+26 IF TYPE=2
IF 'INCEN
QUIT
+27 SET NF=NF+1
+28 SET TEST(NF)=1
SET (DATE(NF),VALUE(NF))=DDATE
+29 IF FEEBASIS=1
SET TEXT(NF)="Fee basis"
+30 IF TYPE=2
SET TEXT(NF)="Census"
+31 IF NF=NGET
SET DONE=1
End DoDot:2
End DoDot:1
+32 SET NFOUND=NF
+33 QUIT
+34 ;
+35 ;======================================================
INP(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,VALUE,TEXT) ;Computed finding for
+1 ;determining if a patient is an inpatient on the evaluation date.
+2 NEW VAIN,VAINDT
+3 SET NFOUND=1
+4 SET (DATE(1),VAINDT)=$$NOW^PXRMDATE
+5 DO INP^VADPT
+6 IF VAIN(1)=""
SET TEST(1)=0
DO KVAR^VADPT
QUIT
+7 SET TEST(1)=1
+8 SET VALUE(1,"PRIMARY PROVIDER")=$PIECE(VAIN(2),U,2)
+9 SET VALUE(1,"TREATING SPECIALTY")=$PIECE(VAIN(3),U,2)
+10 SET VALUE(1,"WARD LOCATION")=$PIECE(VAIN(4),U,2)
+11 SET VALUE(1,"ADMISSION DATE/TIME")=$PIECE(VAIN(7),U,1)
+12 SET VALUE(1,"ADMISSION TYPE")=$PIECE(VAIN(8),U,2)
+13 SET VALUE(1,"ATTENDING PHYSICIAN")=$PIECE(VAIN(11),U,2)
+14 SET TEXT(1)="Patient is an inpatient; admission date/time: "_$$FMTE^XLFDT(VALUE(1,"ADMISSION DATE/TIME"),"5Z")
+15 DO KVAR^VADPT
+16 QUIT
+17 ;
+18 ;======================================================
NEWRACE(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,VALUE,TEXT) ;Computed finding
+1 ;for returning a patient's multi-valued race.
+2 NEW IND,VADM
+3 DO DEM^VADPT
+4 SET NFOUND=VADM(12)
+5 IF NFOUND=0
DO KVA^VADPT
QUIT
+6 SET NGET=$SELECT(NGET<0:-NGET,1:NGET)
+7 IF NFOUND>NGET
SET NFOUND=NGET
+8 FOR IND=1:1:NFOUND
Begin DoDot:1
+9 SET TEST(IND)=1
SET DATE(IND)=$$NOW^PXRMDATE
SET TEXT(IND)=""
+10 SET (VALUE(IND,"VALUE"),VALUE(IND,"RACE"))=$PIECE(VADM(12,IND),U,2)
End DoDot:1
+11 DO KVA^VADPT
+12 QUIT
+13 ;
+14 ;======================================================
PATTYPE(DFN,TEST,DATE,VALUE,TEXT) ;Computed finding to return the patient
+1 ;type
+2 NEW VAEL
+3 SET VALUE=""
+4 SET DATE=$$NOW^PXRMDATE
+5 DO ELIG^VADPT
+6 SET TEST=$SELECT($GET(VAEL(6))'="":1,1:0)
+7 SET VALUE=$PIECE(VAEL(6),U,2)
+8 DO KVAR^VADPT
+9 QUIT
+10 ;
+11 ;======================================================
RACE(DFN,TEST,DATE,VALUE,TEXT) ;Computed finding for checking a patient's race.
+1 NEW RACE
+2 SET DATE=$$NOW^PXRMDATE
+3 ;DBIA #10035
+4 SET RACE=$PIECE($GET(^DPT(DFN,0)),U,6)
+5 IF RACE=""
SET TEST=0
SET VALUE=""
QUIT
+6 QUIT
+7 ;
+8 ;======================================================
SEX(DFN,TEST,DATE,VALUE,TEXT) ;Computed finding for returning a patient's
+1 ;sex.
+2 SET DATE=$$NOW^PXRMDATE
SET TEST=1
+3 IF $DATA(PXRMPDEM)
SET VALUE=PXRMPDEM("SEX")
QUIT
+4 ;DBIA #10035 SEX is a required field.
+5 IF '$DATA(PXRMPDEM)
SET VALUE=$PIECE(^DPT(DFN,0),U,2)
+6 QUIT
+7 ;
SEXOR(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,VALUE,TEXT) ;
+1 NEW ARRAY,IDX,CNT,SDIR,SOSTATUS,SO,SOTYPE,TMPDATE,VADM
+2 DO DEM^VADPT
+3 SET SOSTATUS=$GET(TEST)
SET NFOUND=0
+4 ;collect data from file 2
+5 SET IDX=0
FOR
SET IDX=$ORDER(VADM(14,1,IDX))
if IDX'>0
QUIT
Begin DoDot:1
+6 IF SOSTATUS'=""
IF SOSTATUS'=$PIECE(VADM(14,1,IDX,1),U)
QUIT
+7 SET SO=$PIECE(VADM(14,1,IDX),U)
SET SOTYPE=$PIECE(VADM(14,1,IDX),U,2)
+8 SET TMPDATE=$SELECT(+$PIECE(VADM(14,1,IDX,3),U,2)>0:$PIECE(VADM(14,1,IDX,3),U,2),1:$PIECE(VADM(14,1,IDX,2),U,2))
+9 IF TMPDATE<BDT
QUIT
+10 IF TMPDATE>EDT
QUIT
+11 SET ARRAY(TMPDATE)=""
+12 SET ARRAY(TMPDATE,IDX,"SEXUAL ORIENTATION")=SO
+13 SET ARRAY(TMPDATE,IDX,"SEXUAL ORIENTATION TYPE CODE")=SOTYPE
+14 SET ARRAY(TMPDATE,IDX,"SO STATUS")=$PIECE(VADM(14,1,IDX,1),U)
End DoDot:1
+15 ;handle return based off positive or negative NGET value
+16 SET SDIR=$SELECT(NGET<0:+1,1:-1)
+17 SET TMPDATE=""
+18 FOR
SET TMPDATE=$ORDER(ARRAY(TMPDATE),SDIR)
if TMPDATE=""
QUIT
Begin DoDot:1
+19 SET NFOUND=NFOUND+1
IF NFOUND>NGET
QUIT
+20 SET DATE(NFOUND)=TMPDATE
SET TEST(NFOUND)=1
+21 SET VALUE(NFOUND,"SEXUAL ORIENTATION DAS")=DFN
+22 SET TEXT(NFOUND)="List of sexual orientation:"
+23 SET IDX=0
SET CNT=0
FOR
SET IDX=$ORDER(ARRAY(TMPDATE,IDX))
if IDX'>0
QUIT
Begin DoDot:2
+24 SET VALUE(NFOUND,"SEXUAL ORIENTATION",IDX)=ARRAY(TMPDATE,IDX,"SEXUAL ORIENTATION")
+25 SET VALUE(NFOUND,"SEXUAL ORIENTATION TYPE CODE",IDX)=ARRAY(TMPDATE,IDX,"SEXUAL ORIENTATION TYPE CODE")
+26 SET CNT=CNT+1
SET TEXT(NFOUND,CNT)=" "_VALUE(NFOUND,"SEXUAL ORIENTATION",IDX)
+27 IF VALUE(NFOUND,"SEXUAL ORIENTATION",IDX)="Another Option, please describe"
IF $GET(VADM(14,2))'=""
Begin DoDot:3
+28 SET VALUE(NFOUND,"OTHER DESCRIPTION")=VADM(14,2)
+29 SET CNT=CNT+1
SET TEXT(NFOUND,CNT)=" Description: "_VALUE(NFOUND,"OTHER DESCRIPTION")
End DoDot:3
+30 SET VALUE(NFOUND,"SO STATUS",IDX)=ARRAY(TMPDATE,IDX,"SO STATUS")
+31 SET VALUE(NFOUND,"DIALOG")=1
SET VALUE(NFOUND,"PACKAGE")="REGISTRATION"
SET VALUE(NFOUND,"PACKAGE PREFIX")="DG"
End DoDot:2
End DoDot:1
+32 QUIT
+33 ;
+34 ;======================================================
WASINP(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,VALUE,TEXT) ;Computed finding for
+1 ;determining if a patient was an inpatient in the period defined
+2 ;by BDT and EDT.
+3 ;Access to DGPM covered by DBIA #1378
+4 NEW ADATE,ADM,ADML,AWARD,DDATE,DWARD,IEN,INDT,FDATE,LOS,NOCC,SDIR,TEMP
+5 SET FDATE=$SELECT(TEST="DISCH":"DISCH",1:"ADM")
+6 SET SDIR=$SELECT(NGET<0:1,1:-1)
+7 SET NOCC=$SELECT(NGET<0:-NGET,1:NGET)
+8 SET NFOUND=0
+9 ;Use the "ATID3" index to build a list of past admissions and
+10 ;discharges.
+11 SET INDT=""
+12 FOR
SET INDT=$ORDER(^DGPM("ATID3",DFN,INDT))
if INDT=""
QUIT
Begin DoDot:1
+13 SET IEN=$ORDER(^DGPM("ATID3",DFN,INDT,""))
+14 SET TEMP=^DGPM(IEN,0)
+15 SET DDATE=$PIECE(TEMP,U,1)
+16 SET ADM=$PIECE(TEMP,U,14)
+17 SET ADATE=$PIECE(^DGPM(ADM,0),U,1)
+18 IF $$OVERLAP^PXRMINDX(ADATE,DDATE,BDT,EDT)'="O"
QUIT
+19 SET AWARD=$$GET1^DIQ(405,ADM,.06)
SET DWARD=$$GET1^DIQ(405,IEN,200)
+20 SET ADML(ADATE)=DDATE_U_AWARD_U_DWARD
End DoDot:1
+21 ;Check for the last admission and add it if it is not on the list.
+22 SET INDT=$ORDER(^DGPM("ATID1",DFN,""))
+23 IF INDT'=""
Begin DoDot:1
+24 SET IEN=$ORDER(^DGPM("ATID1",DFN,INDT,""))
+25 SET TEMP=^DGPM(IEN,0)
+26 SET ADATE=$PIECE(TEMP,U,1)
SET AWARD=$$GET1^DIQ(405,IEN,.06)
+27 IF $DATA(ADML(ADATE))
QUIT
+28 SET IEN=$PIECE(TEMP,U,17)
+29 ;Since this is the last admission there may not be a discharge.
+30 SET DDATE=$SELECT(IEN="":$$NOW^PXRMDATE,1:$PIECE(^DGPM(IEN,0),U,1))
+31 IF $$OVERLAP^PXRMINDX(ADATE,DDATE,BDT,EDT)="O"
Begin DoDot:2
+32 SET DWARD=$SELECT(IEN="":"",1:$$GET1^DIQ(405,IEN,200))
+33 SET ADML(ADATE)=DDATE_U_AWARD_U_DWARD
End DoDot:2
End DoDot:1
+34 ;Sort the list.
+35 SET ADATE=""
+36 FOR
SET ADATE=$ORDER(ADML(ADATE),SDIR)
if (NFOUND=NOCC)!(ADATE="")
QUIT
Begin DoDot:1
+37 SET NFOUND=NFOUND+1
SET TEST(NFOUND)=1
+38 SET DDATE=$PIECE(ADML(ADATE),U,1)
SET AWARD=$PIECE(ADML(ADATE),U,2)
SET DWARD=$PIECE(ADML(ADATE),U,3)
+39 IF DDATE=""
SET DDATE=PXRMDATE
+40 SET DATE(NFOUND)=$SELECT(FDATE="DISCH":DDATE,1:ADATE)
+41 SET LOS=$$FMDIFF^XLFDT(DDATE,ADATE)
+42 SET TEMP="Inpatient from: "_$$FMTE^XLFDT(ADATE,"5Z")_" to "
+43 SET TEMP=TEMP_$SELECT(DDATE=PXRMDATE:"now",1:$$FMTE^XLFDT(DDATE,"5Z"))
+44 SET TEMP=TEMP_"; Length of stay "_LOS_" days"
+45 SET TEMP=TEMP_"; Admission ward: "_AWARD
+46 IF DWARD'=""
SET TEMP=TEMP_"; Discharge ward: "_DWARD
+47 SET TEXT(NFOUND)=TEMP
+48 SET VALUE(NFOUND,"ADMISSION DATE")=ADATE
+49 SET VALUE(NFOUND,"ADMISSION WARD")=AWARD
+50 SET VALUE(NFOUND,"DISCHARGE DATE")=DDATE
+51 SET VALUE(NFOUND,"DISCHARGE WARD")=DWARD
+52 SET VALUE(NFOUND,"LENGTH OF STAY")=LOS
End DoDot:1
+53 QUIT
+54 ;
