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

PXRMPDR.m

Go to the documentation of this file.
  1. PXRMPDR ;SLC/AGP,PKR - Patient List Demographic report main routine ;03/06/2015
  1. ;;2.0;CLINICAL REMINDERS;**4,6,12,47**;Feb 04, 2005;Build 291
  1. ;
  1. EN(PLIEN) ; -- main entry point for PXRM PATIENT LIST DEMOGRAPHIC
  1. N ARRAY,DC,DDATA,DELIM,DTOUT,DUOUT
  1. W @IOF
  1. K ^TMP("PXRMPLD",$J),^TMP("PXRMPLN",$J)
  1. S DELIM=0
  1. OPTION ;
  1. W !,"Select the items to include on the report."
  1. ADDSEL D ADDSEL^PXRMPDRS(.DDATA,"ADD")
  1. I $D(DTOUT)!$D(DUOUT) Q
  1. APPSEL D APPSEL^PXRMPDRS(.DDATA,"APP")
  1. I $D(DTOUT)!$D(DUOUT) G ADDSEL
  1. DEMSEL D DEMSEL^PXRMPDRS(.DDATA,"DEM")
  1. I $D(DTOUT)!$D(DUOUT) G APPSEL
  1. PFACSEL S DDATA("PFAC",0)=$$ASKYN^PXRMEUT("N","Include the patient's preferred facility")
  1. I $D(DTOUT)!$D(DUOUT) G DEMSEL
  1. S DDATA("PFAC","LEN")=$S(DDATA("PFAC",0)=1:1,1:0)
  1. ELIGSEL D ELIGSEL^PXRMPDRS(.DDATA,"ELIG")
  1. I $D(DTOUT)!$D(DUOUT) G PFACSEL
  1. DATASEL D DATASEL^PXRMPDRS(PLIEN,.DDATA,"FIND")
  1. I $D(DTOUT)!$D(DUOUT) G ELIGSEL
  1. INPSEL D INPSEL^PXRMPDRS(.DDATA,"INP")
  1. I $D(DTOUT)!$D(DUOUT) G DATASEL
  1. REMDATA D REMSEL^PXRMPDRS(PLIEN,.DDATA,"REM")
  1. I $D(DTOUT)!$D(DUOUT) G INPSEL
  1. S DELIM=$$ASKYN^PXRMEUT("Y","Delimited Report:")
  1. I $D(DTOUT)!$D(DUOUT) G REMDATA
  1. S DC=$S(DELIM:$$DELIMSEL^PXRMXSD,1:U)
  1. I $D(DTOUT)!$D(DUOUT) G OPTION
  1. DEVICE ;
  1. N DESC,DIR,PXRMQUE,RTN,SAVE,%ZIS
  1. S %ZIS="M"
  1. S DESC="Patient List Demographic Report"
  1. S RTN="GETPDATA^PXRMPDR(DELIM,DC,PLIEN,.DDATA)"
  1. S SAVE("DELIM")="",SAVE("DC")="",SAVE("PLIEN")=""
  1. S SAVE("DDATA(")=""
  1. S PXRMQUE=$$DEVICE^PXRMXQUE(RTN,DESC,.SAVE,.%ZIS,1)
  1. I PXRMQUE'="" G EXIT
  1. I $D(DTOUT)!$D(DUOUT) G EXIT
  1. S DIR(0)="E" D ^DIR
  1. EXIT D KVA^VADPT
  1. K ^TMP("PXRMPLD",$J),^TMP("PXRMPLN",$J)
  1. Q
  1. ;
  1. GETPDATA(DELIM,DC,PLIEN,DDATA) ;
  1. N DATA,DATE,DFN,DTYPE,ERRMSG
  1. N GETADD,GETAPP,GETDEM,GETELIG,GETFIND,GETINP,GETREM
  1. N IEN,IND,JND,KND,LND
  1. N LISTNAME,PIECE
  1. N PDATA,PNAME,RIEN,TDATA
  1. K ^TMP("PXRMPD",$J)
  1. S LISTNAME=$P(^PXRMXP(810.5,PLIEN,0),U,1)
  1. S GETDEM=$S(DDATA("DEM","LEN")>0:1,1:0)
  1. S GETADD=$S(DDATA("ADD","LEN")>0:1,1:0)
  1. S GETINP=$S(DDATA("INP","LEN")>0:1,1:0)
  1. S GETELIG=$S(DDATA("ELIG","LEN")>0:1,1:0)
  1. S GETAPP=$S(DDATA("APP","LEN")>0:1,1:0)
  1. S GETFIND=$S(DDATA("FIND","LEN")>0:1,1:0)
  1. S GETREM=$S(DDATA("REM","LEN")>0:1,1:0)
  1. S IEN=0
  1. F S IEN=+$O(^PXRMXP(810.5,PLIEN,30,IEN)) Q:IEN=0 D
  1. . S DFN=$P(^PXRMXP(810.5,PLIEN,30,IEN,0),U,1) I DFN="" Q
  1. .;#DBIA 10035
  1. . S PNAME=$P($G(^DPT(DFN,0)),U,1)
  1. . I PNAME="" S PNAME="UNDEFINED"_DFN
  1. . S ^TMP("PXRMPLN",$J,PNAME,DFN)=""
  1. . S PDATA=""
  1. . I GETDEM D
  1. .. N VADM
  1. .. D DEM^VADPT
  1. .. F IND=1:1:DDATA("DEM","LEN") D
  1. ... S JND=$P(DDATA("DEM"),",",IND)
  1. ... S KND=0
  1. ... F S KND=$O(DDATA("DEM",JND,KND)) Q:KND="" D
  1. .... S PIECE=$P(DDATA("DEM",JND,KND),U,2)
  1. .... S TDATA=$P(VADM(KND),U,PIECE)
  1. .... S LND=""
  1. .... F S LND=$O(VADM(KND,LND)) Q:LND="" D
  1. ..... I TDATA'="" S TDATA=TDATA_"~"
  1. ..... S TDATA=TDATA_$P(VADM(KND,LND),U,PIECE)
  1. .... I KND=2,'DDATA("DEM","FULLSSN") S TDATA=$E(TDATA,8,11)
  1. .... S $P(PDATA,U,KND)=TDATA
  1. .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"DEM")=PDATA,PDATA=""
  1. . I DDATA("PFAC",0)=1 D
  1. ..;DBIA #1850
  1. .. S TDATA=$$GET1^DIQ(2,DFN,27.02,"E","","ERRMSG")
  1. .. I TDATA="" S TDATA="NONE"
  1. .. S ^TMP("PXRMPLD",$J,DFN,"PFAC")=TDATA
  1. . I GETADD D
  1. .. N ADDTYPE,LND,MND,OFFSET,VAPA
  1. .. D ADD^VADPT
  1. .. S ADDTYPE=$S(((DT'<VAPA(9))&(DT'>VAPA(10))):"T",1:"R")
  1. ..;If the confidential address is active make sure the categories
  1. ..;match those that were selected. VHA Directive 2003-025 states
  1. ..;the confidential address must be used if it is active.
  1. .. I VAPA(12),DDATA("ADD")["1," D
  1. ... F LND=1:1:DDATA("ADD",22,"LEN") D
  1. .... S MND=$P(DDATA("ADD",22,"LIST"),",",LND)
  1. ....;If this category = VAPA(22,MND), was selected use it.
  1. .... I $D(VAPA(22,MND)) S ADDTYPE="C"
  1. .. S OFFSET=$S(ADDTYPE="C":12,1:0)
  1. .. S (VAPA(23),VAPA(23+OFFSET))=ADDTYPE
  1. .. F IND=1:1:DDATA("ADD","LEN") D
  1. ... S JND=$P(DDATA("ADD"),",",IND)
  1. ...;The offset is only used for addresses.
  1. ... I JND=2 S OFFSET=0
  1. ... S KND=0
  1. ... F S KND=+$O(DDATA("ADD",JND,KND)) Q:KND=0 D
  1. .... S PIECE=$P(DDATA("ADD",JND,KND),U,2)
  1. .... S TDATA=$P(VAPA(KND+OFFSET),U,PIECE)
  1. .... S $P(PDATA,U,KND)=TDATA
  1. .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"ADD")=PDATA,PDATA=""
  1. . I GETINP D
  1. .. N VAIN
  1. .. D INP^VADPT
  1. .. F IND=1:1:DDATA("INP","LEN") D
  1. ... S JND=$P(DDATA("INP"),",",IND)
  1. ... S KND=0
  1. ... F S KND=$O(DDATA("INP",JND,KND)) Q:KND="" D
  1. .... S PIECE=$P(DDATA("INP",JND,KND),U,2)
  1. .... S TDATA=$P(VAIN(KND),U,PIECE)
  1. .... S $P(PDATA,U,KND)=TDATA
  1. .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"INP")=PDATA,PDATA=""
  1. . I GETELIG D
  1. .. N VAEL
  1. .. D ELIG^VADPT
  1. .. F IND=1:1:DDATA("ELIG","LEN") D
  1. ... S JND=$P(DDATA("ELIG"),",",IND)
  1. ... S KND=0
  1. ... F S KND=$O(DDATA("ELIG",JND,KND)) Q:KND="" D
  1. .... S PIECE=$P(DDATA("ELIG",JND,KND),U,2)
  1. .... S TDATA=$P(VAEL(KND),U,PIECE)
  1. .... I KND=4 S TDATA=$S(TDATA=1:"YES",1:"NO")
  1. .... S $P(PDATA,U,KND)=TDATA
  1. .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"ELIG")=PDATA,PDATA=""
  1. . D KVA^VADPT
  1. . I GETREM D
  1. .. S IND=0
  1. .. F S IND=$O(DDATA("REM","IEN",IND)) Q:IND="" D
  1. ... S PDATA=$G(^PXRMXP(810.5,PLIEN,30,IEN,"REM",IND,0))
  1. ... I PDATA="" Q
  1. ... S RIEN=$P(PDATA,U,1)
  1. ... S ^TMP("PXRMPLD",$J,DFN,"REM",RIEN)=PDATA,PDATA=""
  1. . I GETFIND D
  1. .. N DL
  1. .. F IND=1:1:DDATA("FIND","LEN") D
  1. ... S JND=$P(DDATA("FIND"),",",IND)
  1. ... S DTYPE=DDATA("FIND",JND,JND)
  1. ... S KND=$O(^PXRMXP(810.5,PLIEN,30,IEN,"DATA","B",DTYPE,""))
  1. ... S DL=$S(KND="":0,1:$L(^PXRMXP(810.5,PLIEN,30,IEN,"DATA",KND,0),U))
  1. ... S DATA=$S(KND="":"",1:$P(^PXRMXP(810.5,PLIEN,30,IEN,"DATA",KND,0),U,2,DL))
  1. ... S ^TMP("PXRMPLD",$J,DFN,"FIND",JND)=DATA
  1. ;Get appointment data for all patients on the list.
  1. I GETAPP D
  1. . N APPLIST,ARRAY,COUNT,DONE
  1. . S ARRAY(1)=DT,ARRAY(3)="I;R",ARRAY(4)="^TMP($J,""PXRMPL"""
  1. . S ARRAY("FLDS")=""
  1. . F IND=1:1:DDATA("APP","LEN") D
  1. .. S JND=$P(DDATA("APP"),",",IND)
  1. .. S KND=0
  1. .. F S KND=$O(DDATA("APP",JND,KND)) Q:KND="" S ARRAY("FLDS")=ARRAY("FLDS")_KND_";"
  1. . K ^TMP($J,"PXRMPL"),^TMP($J,"SDAMA301")
  1. . S IND=0
  1. . F S IND=+$O(^PXRMXP(810.5,PLIEN,30,IND)) Q:IND=0 D
  1. .. S DFN=$P(^PXRMXP(810.5,PLIEN,30,IND,0),U,1)
  1. .. I DFN'="" S ^TMP($J,"PXRMPL",DFN)=""
  1. . S COUNT=$$SDAPI^SDAMA301(.ARRAY)
  1. . I COUNT=-1 D Q
  1. .. D APPERR^PXRMPDRS
  1. .. S DDATA("APP","ERROR")=""
  1. .. K ^TMP($J,"PXRMPL"),^TMP($J,"SDAMA301")
  1. .;Data is ^TMP($J,"SDAMA301",DFN,CLINIC,DATE)=DATE^CLINIC
  1. .;Resort by DATE then CLINIC.
  1. . S DFN=""
  1. . F S DFN=$O(^TMP($J,"SDAMA301",DFN)) Q:DFN="" D
  1. .. K APPLIST
  1. .. S JND=0
  1. .. F S JND=$O(^TMP($J,"SDAMA301",DFN,JND)) Q:JND="" D
  1. ... S DATE=0
  1. ... F S DATE=$O(^TMP($J,"SDAMA301",DFN,JND,DATE)) Q:DATE="" S APPLIST(DATE,JND)=""
  1. .. S (DATE,DONE,KND)=0
  1. .. F S DATE=$O(APPLIST(DATE)) Q:(DONE)!(DATE="") D
  1. ... S JND=0
  1. ... F S JND=$O(APPLIST(DATE,JND)) Q:(DONE)!(JND="") D
  1. .... S KND=KND+1
  1. .... I KND=DDATA("APP","MAX") S DONE=1
  1. .... S TDATA=^TMP($J,"SDAMA301",DFN,JND,DATE)
  1. .... S PDATA=$$FMTE^XLFDT($P(TDATA,U,1))
  1. .... S TDATA=$P(TDATA,U,2),TDATA=$P(TDATA,";",2)
  1. .... S PDATA=PDATA_U_TDATA
  1. .... S ^TMP("PXRMPLD",$J,DFN,"APP",KND)=PDATA
  1. . K ^TMP($J,"PXRMPL"),^TMP($J,"SDAMA301")
  1. I DELIM=1 D DELIMPR^PXRMPDRP(DC,PLIEN,.DDATA)
  1. I DELIM=0 D REGPR^PXRMPDRP(PLIEN,.DDATA)
  1. Q
  1. ;
  1. LENGTH(STR,STR1) ;
  1. I ($L(STR)+$L(STR1))>245 W !,STR S STR=STR1
  1. E S STR=STR_U_STR1,STR1=""
  1. Q
  1. ;