- PXRMPDR ;SLC/AGP,PKR - Patient List Demographic report main routine ;03/06/2015
- ;;2.0;CLINICAL REMINDERS;**4,6,12,47**;Feb 04, 2005;Build 291
- ;
- EN(PLIEN) ; -- main entry point for PXRM PATIENT LIST DEMOGRAPHIC
- N ARRAY,DC,DDATA,DELIM,DTOUT,DUOUT
- W @IOF
- K ^TMP("PXRMPLD",$J),^TMP("PXRMPLN",$J)
- S DELIM=0
- OPTION ;
- W !,"Select the items to include on the report."
- ADDSEL D ADDSEL^PXRMPDRS(.DDATA,"ADD")
- I $D(DTOUT)!$D(DUOUT) Q
- APPSEL D APPSEL^PXRMPDRS(.DDATA,"APP")
- I $D(DTOUT)!$D(DUOUT) G ADDSEL
- DEMSEL D DEMSEL^PXRMPDRS(.DDATA,"DEM")
- I $D(DTOUT)!$D(DUOUT) G APPSEL
- PFACSEL S DDATA("PFAC",0)=$$ASKYN^PXRMEUT("N","Include the patient's preferred facility")
- I $D(DTOUT)!$D(DUOUT) G DEMSEL
- S DDATA("PFAC","LEN")=$S(DDATA("PFAC",0)=1:1,1:0)
- ELIGSEL D ELIGSEL^PXRMPDRS(.DDATA,"ELIG")
- I $D(DTOUT)!$D(DUOUT) G PFACSEL
- DATASEL D DATASEL^PXRMPDRS(PLIEN,.DDATA,"FIND")
- I $D(DTOUT)!$D(DUOUT) G ELIGSEL
- INPSEL D INPSEL^PXRMPDRS(.DDATA,"INP")
- I $D(DTOUT)!$D(DUOUT) G DATASEL
- REMDATA D REMSEL^PXRMPDRS(PLIEN,.DDATA,"REM")
- I $D(DTOUT)!$D(DUOUT) G INPSEL
- S DELIM=$$ASKYN^PXRMEUT("Y","Delimited Report:")
- I $D(DTOUT)!$D(DUOUT) G REMDATA
- S DC=$S(DELIM:$$DELIMSEL^PXRMXSD,1:U)
- I $D(DTOUT)!$D(DUOUT) G OPTION
- DEVICE ;
- N DESC,DIR,PXRMQUE,RTN,SAVE,%ZIS
- S %ZIS="M"
- S DESC="Patient List Demographic Report"
- S RTN="GETPDATA^PXRMPDR(DELIM,DC,PLIEN,.DDATA)"
- S SAVE("DELIM")="",SAVE("DC")="",SAVE("PLIEN")=""
- S SAVE("DDATA(")=""
- S PXRMQUE=$$DEVICE^PXRMXQUE(RTN,DESC,.SAVE,.%ZIS,1)
- I PXRMQUE'="" G EXIT
- I $D(DTOUT)!$D(DUOUT) G EXIT
- S DIR(0)="E" D ^DIR
- EXIT D KVA^VADPT
- K ^TMP("PXRMPLD",$J),^TMP("PXRMPLN",$J)
- Q
- ;
- GETPDATA(DELIM,DC,PLIEN,DDATA) ;
- N DATA,DATE,DFN,DTYPE,ERRMSG
- N GETADD,GETAPP,GETDEM,GETELIG,GETFIND,GETINP,GETREM
- N IEN,IND,JND,KND,LND
- N LISTNAME,PIECE
- N PDATA,PNAME,RIEN,TDATA
- K ^TMP("PXRMPD",$J)
- S LISTNAME=$P(^PXRMXP(810.5,PLIEN,0),U,1)
- S GETDEM=$S(DDATA("DEM","LEN")>0:1,1:0)
- S GETADD=$S(DDATA("ADD","LEN")>0:1,1:0)
- S GETINP=$S(DDATA("INP","LEN")>0:1,1:0)
- S GETELIG=$S(DDATA("ELIG","LEN")>0:1,1:0)
- S GETAPP=$S(DDATA("APP","LEN")>0:1,1:0)
- S GETFIND=$S(DDATA("FIND","LEN")>0:1,1:0)
- S GETREM=$S(DDATA("REM","LEN")>0:1,1:0)
- S IEN=0
- F S IEN=+$O(^PXRMXP(810.5,PLIEN,30,IEN)) Q:IEN=0 D
- . S DFN=$P(^PXRMXP(810.5,PLIEN,30,IEN,0),U,1) I DFN="" Q
- .;#DBIA 10035
- . S PNAME=$P($G(^DPT(DFN,0)),U,1)
- . I PNAME="" S PNAME="UNDEFINED"_DFN
- . S ^TMP("PXRMPLN",$J,PNAME,DFN)=""
- . S PDATA=""
- . I GETDEM D
- .. N VADM
- .. D DEM^VADPT
- .. F IND=1:1:DDATA("DEM","LEN") D
- ... S JND=$P(DDATA("DEM"),",",IND)
- ... S KND=0
- ... F S KND=$O(DDATA("DEM",JND,KND)) Q:KND="" D
- .... S PIECE=$P(DDATA("DEM",JND,KND),U,2)
- .... S TDATA=$P(VADM(KND),U,PIECE)
- .... S LND=""
- .... F S LND=$O(VADM(KND,LND)) Q:LND="" D
- ..... I TDATA'="" S TDATA=TDATA_"~"
- ..... S TDATA=TDATA_$P(VADM(KND,LND),U,PIECE)
- .... I KND=2,'DDATA("DEM","FULLSSN") S TDATA=$E(TDATA,8,11)
- .... S $P(PDATA,U,KND)=TDATA
- .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"DEM")=PDATA,PDATA=""
- . I DDATA("PFAC",0)=1 D
- ..;DBIA #1850
- .. S TDATA=$$GET1^DIQ(2,DFN,27.02,"E","","ERRMSG")
- .. I TDATA="" S TDATA="NONE"
- .. S ^TMP("PXRMPLD",$J,DFN,"PFAC")=TDATA
- . I GETADD D
- .. N ADDTYPE,LND,MND,OFFSET,VAPA
- .. D ADD^VADPT
- .. S ADDTYPE=$S(((DT'<VAPA(9))&(DT'>VAPA(10))):"T",1:"R")
- ..;If the confidential address is active make sure the categories
- ..;match those that were selected. VHA Directive 2003-025 states
- ..;the confidential address must be used if it is active.
- .. I VAPA(12),DDATA("ADD")["1," D
- ... F LND=1:1:DDATA("ADD",22,"LEN") D
- .... S MND=$P(DDATA("ADD",22,"LIST"),",",LND)
- ....;If this category = VAPA(22,MND), was selected use it.
- .... I $D(VAPA(22,MND)) S ADDTYPE="C"
- .. S OFFSET=$S(ADDTYPE="C":12,1:0)
- .. S (VAPA(23),VAPA(23+OFFSET))=ADDTYPE
- .. F IND=1:1:DDATA("ADD","LEN") D
- ... S JND=$P(DDATA("ADD"),",",IND)
- ...;The offset is only used for addresses.
- ... I JND=2 S OFFSET=0
- ... S KND=0
- ... F S KND=+$O(DDATA("ADD",JND,KND)) Q:KND=0 D
- .... S PIECE=$P(DDATA("ADD",JND,KND),U,2)
- .... S TDATA=$P(VAPA(KND+OFFSET),U,PIECE)
- .... S $P(PDATA,U,KND)=TDATA
- .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"ADD")=PDATA,PDATA=""
- . I GETINP D
- .. N VAIN
- .. D INP^VADPT
- .. F IND=1:1:DDATA("INP","LEN") D
- ... S JND=$P(DDATA("INP"),",",IND)
- ... S KND=0
- ... F S KND=$O(DDATA("INP",JND,KND)) Q:KND="" D
- .... S PIECE=$P(DDATA("INP",JND,KND),U,2)
- .... S TDATA=$P(VAIN(KND),U,PIECE)
- .... S $P(PDATA,U,KND)=TDATA
- .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"INP")=PDATA,PDATA=""
- . I GETELIG D
- .. N VAEL
- .. D ELIG^VADPT
- .. F IND=1:1:DDATA("ELIG","LEN") D
- ... S JND=$P(DDATA("ELIG"),",",IND)
- ... S KND=0
- ... F S KND=$O(DDATA("ELIG",JND,KND)) Q:KND="" D
- .... S PIECE=$P(DDATA("ELIG",JND,KND),U,2)
- .... S TDATA=$P(VAEL(KND),U,PIECE)
- .... I KND=4 S TDATA=$S(TDATA=1:"YES",1:"NO")
- .... S $P(PDATA,U,KND)=TDATA
- .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"ELIG")=PDATA,PDATA=""
- . D KVA^VADPT
- . I GETREM D
- .. S IND=0
- .. F S IND=$O(DDATA("REM","IEN",IND)) Q:IND="" D
- ... S PDATA=$G(^PXRMXP(810.5,PLIEN,30,IEN,"REM",IND,0))
- ... I PDATA="" Q
- ... S RIEN=$P(PDATA,U,1)
- ... S ^TMP("PXRMPLD",$J,DFN,"REM",RIEN)=PDATA,PDATA=""
- . I GETFIND D
- .. N DL
- .. F IND=1:1:DDATA("FIND","LEN") D
- ... S JND=$P(DDATA("FIND"),",",IND)
- ... S DTYPE=DDATA("FIND",JND,JND)
- ... S KND=$O(^PXRMXP(810.5,PLIEN,30,IEN,"DATA","B",DTYPE,""))
- ... S DL=$S(KND="":0,1:$L(^PXRMXP(810.5,PLIEN,30,IEN,"DATA",KND,0),U))
- ... S DATA=$S(KND="":"",1:$P(^PXRMXP(810.5,PLIEN,30,IEN,"DATA",KND,0),U,2,DL))
- ... S ^TMP("PXRMPLD",$J,DFN,"FIND",JND)=DATA
- ;Get appointment data for all patients on the list.
- I GETAPP D
- . N APPLIST,ARRAY,COUNT,DONE
- . S ARRAY(1)=DT,ARRAY(3)="I;R",ARRAY(4)="^TMP($J,""PXRMPL"""
- . S ARRAY("FLDS")=""
- . F IND=1:1:DDATA("APP","LEN") D
- .. S JND=$P(DDATA("APP"),",",IND)
- .. S KND=0
- .. F S KND=$O(DDATA("APP",JND,KND)) Q:KND="" S ARRAY("FLDS")=ARRAY("FLDS")_KND_";"
- . K ^TMP($J,"PXRMPL"),^TMP($J,"SDAMA301")
- . S IND=0
- . F S IND=+$O(^PXRMXP(810.5,PLIEN,30,IND)) Q:IND=0 D
- .. S DFN=$P(^PXRMXP(810.5,PLIEN,30,IND,0),U,1)
- .. I DFN'="" S ^TMP($J,"PXRMPL",DFN)=""
- . S COUNT=$$SDAPI^SDAMA301(.ARRAY)
- . I COUNT=-1 D Q
- .. D APPERR^PXRMPDRS
- .. S DDATA("APP","ERROR")=""
- .. K ^TMP($J,"PXRMPL"),^TMP($J,"SDAMA301")
- .;Data is ^TMP($J,"SDAMA301",DFN,CLINIC,DATE)=DATE^CLINIC
- .;Resort by DATE then CLINIC.
- . S DFN=""
- . F S DFN=$O(^TMP($J,"SDAMA301",DFN)) Q:DFN="" D
- .. K APPLIST
- .. S JND=0
- .. F S JND=$O(^TMP($J,"SDAMA301",DFN,JND)) Q:JND="" D
- ... S DATE=0
- ... F S DATE=$O(^TMP($J,"SDAMA301",DFN,JND,DATE)) Q:DATE="" S APPLIST(DATE,JND)=""
- .. S (DATE,DONE,KND)=0
- .. F S DATE=$O(APPLIST(DATE)) Q:(DONE)!(DATE="") D
- ... S JND=0
- ... F S JND=$O(APPLIST(DATE,JND)) Q:(DONE)!(JND="") D
- .... S KND=KND+1
- .... I KND=DDATA("APP","MAX") S DONE=1
- .... S TDATA=^TMP($J,"SDAMA301",DFN,JND,DATE)
- .... S PDATA=$$FMTE^XLFDT($P(TDATA,U,1))
- .... S TDATA=$P(TDATA,U,2),TDATA=$P(TDATA,";",2)
- .... S PDATA=PDATA_U_TDATA
- .... S ^TMP("PXRMPLD",$J,DFN,"APP",KND)=PDATA
- . K ^TMP($J,"PXRMPL"),^TMP($J,"SDAMA301")
- I DELIM=1 D DELIMPR^PXRMPDRP(DC,PLIEN,.DDATA)
- I DELIM=0 D REGPR^PXRMPDRP(PLIEN,.DDATA)
- Q
- ;
- LENGTH(STR,STR1) ;
- I ($L(STR)+$L(STR1))>245 W !,STR S STR=STR1
- E S STR=STR_U_STR1,STR1=""
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMPDR 7406 printed Feb 18, 2025@23:14:50 Page 2
- 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
- +2 ;
- EN(PLIEN) ; -- main entry point for PXRM PATIENT LIST DEMOGRAPHIC
- +1 NEW ARRAY,DC,DDATA,DELIM,DTOUT,DUOUT
- +2 WRITE @IOF
- +3 KILL ^TMP("PXRMPLD",$JOB),^TMP("PXRMPLN",$JOB)
- +4 SET DELIM=0
- OPTION ;
- +1 WRITE !,"Select the items to include on the report."
- ADDSEL DO ADDSEL^PXRMPDRS(.DDATA,"ADD")
- +1 IF $DATA(DTOUT)!$DATA(DUOUT)
- QUIT
- APPSEL DO APPSEL^PXRMPDRS(.DDATA,"APP")
- +1 IF $DATA(DTOUT)!$DATA(DUOUT)
- GOTO ADDSEL
- DEMSEL DO DEMSEL^PXRMPDRS(.DDATA,"DEM")
- +1 IF $DATA(DTOUT)!$DATA(DUOUT)
- GOTO APPSEL
- PFACSEL SET DDATA("PFAC",0)=$$ASKYN^PXRMEUT("N","Include the patient's preferred facility")
- +1 IF $DATA(DTOUT)!$DATA(DUOUT)
- GOTO DEMSEL
- +2 SET DDATA("PFAC","LEN")=$SELECT(DDATA("PFAC",0)=1:1,1:0)
- ELIGSEL DO ELIGSEL^PXRMPDRS(.DDATA,"ELIG")
- +1 IF $DATA(DTOUT)!$DATA(DUOUT)
- GOTO PFACSEL
- DATASEL DO DATASEL^PXRMPDRS(PLIEN,.DDATA,"FIND")
- +1 IF $DATA(DTOUT)!$DATA(DUOUT)
- GOTO ELIGSEL
- INPSEL DO INPSEL^PXRMPDRS(.DDATA,"INP")
- +1 IF $DATA(DTOUT)!$DATA(DUOUT)
- GOTO DATASEL
- REMDATA DO REMSEL^PXRMPDRS(PLIEN,.DDATA,"REM")
- +1 IF $DATA(DTOUT)!$DATA(DUOUT)
- GOTO INPSEL
- +2 SET DELIM=$$ASKYN^PXRMEUT("Y","Delimited Report:")
- +3 IF $DATA(DTOUT)!$DATA(DUOUT)
- GOTO REMDATA
- +4 SET DC=$SELECT(DELIM:$$DELIMSEL^PXRMXSD,1:U)
- +5 IF $DATA(DTOUT)!$DATA(DUOUT)
- GOTO OPTION
- DEVICE ;
- +1 NEW DESC,DIR,PXRMQUE,RTN,SAVE,%ZIS
- +2 SET %ZIS="M"
- +3 SET DESC="Patient List Demographic Report"
- +4 SET RTN="GETPDATA^PXRMPDR(DELIM,DC,PLIEN,.DDATA)"
- +5 SET SAVE("DELIM")=""
- SET SAVE("DC")=""
- SET SAVE("PLIEN")=""
- +6 SET SAVE("DDATA(")=""
- +7 SET PXRMQUE=$$DEVICE^PXRMXQUE(RTN,DESC,.SAVE,.%ZIS,1)
- +8 IF PXRMQUE'=""
- GOTO EXIT
- +9 IF $DATA(DTOUT)!$DATA(DUOUT)
- GOTO EXIT
- +10 SET DIR(0)="E"
- DO ^DIR
- EXIT DO KVA^VADPT
- +1 KILL ^TMP("PXRMPLD",$JOB),^TMP("PXRMPLN",$JOB)
- +2 QUIT
- +3 ;
- GETPDATA(DELIM,DC,PLIEN,DDATA) ;
- +1 NEW DATA,DATE,DFN,DTYPE,ERRMSG
- +2 NEW GETADD,GETAPP,GETDEM,GETELIG,GETFIND,GETINP,GETREM
- +3 NEW IEN,IND,JND,KND,LND
- +4 NEW LISTNAME,PIECE
- +5 NEW PDATA,PNAME,RIEN,TDATA
- +6 KILL ^TMP("PXRMPD",$JOB)
- +7 SET LISTNAME=$PIECE(^PXRMXP(810.5,PLIEN,0),U,1)
- +8 SET GETDEM=$SELECT(DDATA("DEM","LEN")>0:1,1:0)
- +9 SET GETADD=$SELECT(DDATA("ADD","LEN")>0:1,1:0)
- +10 SET GETINP=$SELECT(DDATA("INP","LEN")>0:1,1:0)
- +11 SET GETELIG=$SELECT(DDATA("ELIG","LEN")>0:1,1:0)
- +12 SET GETAPP=$SELECT(DDATA("APP","LEN")>0:1,1:0)
- +13 SET GETFIND=$SELECT(DDATA("FIND","LEN")>0:1,1:0)
- +14 SET GETREM=$SELECT(DDATA("REM","LEN")>0:1,1:0)
- +15 SET IEN=0
- +16 FOR
- SET IEN=+$ORDER(^PXRMXP(810.5,PLIEN,30,IEN))
- if IEN=0
- QUIT
- Begin DoDot:1
- +17 SET DFN=$PIECE(^PXRMXP(810.5,PLIEN,30,IEN,0),U,1)
- IF DFN=""
- QUIT
- +18 ;#DBIA 10035
- +19 SET PNAME=$PIECE($GET(^DPT(DFN,0)),U,1)
- +20 IF PNAME=""
- SET PNAME="UNDEFINED"_DFN
- +21 SET ^TMP("PXRMPLN",$JOB,PNAME,DFN)=""
- +22 SET PDATA=""
- +23 IF GETDEM
- Begin DoDot:2
- +24 NEW VADM
- +25 DO DEM^VADPT
- +26 FOR IND=1:1:DDATA("DEM","LEN")
- Begin DoDot:3
- +27 SET JND=$PIECE(DDATA("DEM"),",",IND)
- +28 SET KND=0
- +29 FOR
- SET KND=$ORDER(DDATA("DEM",JND,KND))
- if KND=""
- QUIT
- Begin DoDot:4
- +30 SET PIECE=$PIECE(DDATA("DEM",JND,KND),U,2)
- +31 SET TDATA=$PIECE(VADM(KND),U,PIECE)
- +32 SET LND=""
- +33 FOR
- SET LND=$ORDER(VADM(KND,LND))
- if LND=""
- QUIT
- Begin DoDot:5
- +34 IF TDATA'=""
- SET TDATA=TDATA_"~"
- +35 SET TDATA=TDATA_$PIECE(VADM(KND,LND),U,PIECE)
- End DoDot:5
- +36 IF KND=2
- IF 'DDATA("DEM","FULLSSN")
- SET TDATA=$EXTRACT(TDATA,8,11)
- +37 SET $PIECE(PDATA,U,KND)=TDATA
- End DoDot:4
- End DoDot:3
- +38 IF PDATA'=""
- SET ^TMP("PXRMPLD",$JOB,DFN,"DEM")=PDATA
- SET PDATA=""
- End DoDot:2
- +39 IF DDATA("PFAC",0)=1
- Begin DoDot:2
- +40 ;DBIA #1850
- +41 SET TDATA=$$GET1^DIQ(2,DFN,27.02,"E","","ERRMSG")
- +42 IF TDATA=""
- SET TDATA="NONE"
- +43 SET ^TMP("PXRMPLD",$JOB,DFN,"PFAC")=TDATA
- End DoDot:2
- +44 IF GETADD
- Begin DoDot:2
- +45 NEW ADDTYPE,LND,MND,OFFSET,VAPA
- +46 DO ADD^VADPT
- +47 SET ADDTYPE=$SELECT(((DT'<VAPA(9))&(DT'>VAPA(10))):"T",1:"R")
- +48 ;If the confidential address is active make sure the categories
- +49 ;match those that were selected. VHA Directive 2003-025 states
- +50 ;the confidential address must be used if it is active.
- +51 IF VAPA(12)
- IF DDATA("ADD")["1,"
- Begin DoDot:3
- +52 FOR LND=1:1:DDATA("ADD",22,"LEN")
- Begin DoDot:4
- +53 SET MND=$PIECE(DDATA("ADD",22,"LIST"),",",LND)
- +54 ;If this category = VAPA(22,MND), was selected use it.
- +55 IF $DATA(VAPA(22,MND))
- SET ADDTYPE="C"
- End DoDot:4
- End DoDot:3
- +56 SET OFFSET=$SELECT(ADDTYPE="C":12,1:0)
- +57 SET (VAPA(23),VAPA(23+OFFSET))=ADDTYPE
- +58 FOR IND=1:1:DDATA("ADD","LEN")
- Begin DoDot:3
- +59 SET JND=$PIECE(DDATA("ADD"),",",IND)
- +60 ;The offset is only used for addresses.
- +61 IF JND=2
- SET OFFSET=0
- +62 SET KND=0
- +63 FOR
- SET KND=+$ORDER(DDATA("ADD",JND,KND))
- if KND=0
- QUIT
- Begin DoDot:4
- +64 SET PIECE=$PIECE(DDATA("ADD",JND,KND),U,2)
- +65 SET TDATA=$PIECE(VAPA(KND+OFFSET),U,PIECE)
- +66 SET $PIECE(PDATA,U,KND)=TDATA
- End DoDot:4
- End DoDot:3
- +67 IF PDATA'=""
- SET ^TMP("PXRMPLD",$JOB,DFN,"ADD")=PDATA
- SET PDATA=""
- End DoDot:2
- +68 IF GETINP
- Begin DoDot:2
- +69 NEW VAIN
- +70 DO INP^VADPT
- +71 FOR IND=1:1:DDATA("INP","LEN")
- Begin DoDot:3
- +72 SET JND=$PIECE(DDATA("INP"),",",IND)
- +73 SET KND=0
- +74 FOR
- SET KND=$ORDER(DDATA("INP",JND,KND))
- if KND=""
- QUIT
- Begin DoDot:4
- +75 SET PIECE=$PIECE(DDATA("INP",JND,KND),U,2)
- +76 SET TDATA=$PIECE(VAIN(KND),U,PIECE)
- +77 SET $PIECE(PDATA,U,KND)=TDATA
- End DoDot:4
- End DoDot:3
- +78 IF PDATA'=""
- SET ^TMP("PXRMPLD",$JOB,DFN,"INP")=PDATA
- SET PDATA=""
- End DoDot:2
- +79 IF GETELIG
- Begin DoDot:2
- +80 NEW VAEL
- +81 DO ELIG^VADPT
- +82 FOR IND=1:1:DDATA("ELIG","LEN")
- Begin DoDot:3
- +83 SET JND=$PIECE(DDATA("ELIG"),",",IND)
- +84 SET KND=0
- +85 FOR
- SET KND=$ORDER(DDATA("ELIG",JND,KND))
- if KND=""
- QUIT
- Begin DoDot:4
- +86 SET PIECE=$PIECE(DDATA("ELIG",JND,KND),U,2)
- +87 SET TDATA=$PIECE(VAEL(KND),U,PIECE)
- +88 IF KND=4
- SET TDATA=$SELECT(TDATA=1:"YES",1:"NO")
- +89 SET $PIECE(PDATA,U,KND)=TDATA
- End DoDot:4
- End DoDot:3
- +90 IF PDATA'=""
- SET ^TMP("PXRMPLD",$JOB,DFN,"ELIG")=PDATA
- SET PDATA=""
- End DoDot:2
- +91 DO KVA^VADPT
- +92 IF GETREM
- Begin DoDot:2
- +93 SET IND=0
- +94 FOR
- SET IND=$ORDER(DDATA("REM","IEN",IND))
- if IND=""
- QUIT
- Begin DoDot:3
- +95 SET PDATA=$GET(^PXRMXP(810.5,PLIEN,30,IEN,"REM",IND,0))
- +96 IF PDATA=""
- QUIT
- +97 SET RIEN=$PIECE(PDATA,U,1)
- +98 SET ^TMP("PXRMPLD",$JOB,DFN,"REM",RIEN)=PDATA
- SET PDATA=""
- End DoDot:3
- End DoDot:2
- +99 IF GETFIND
- Begin DoDot:2
- +100 NEW DL
- +101 FOR IND=1:1:DDATA("FIND","LEN")
- Begin DoDot:3
- +102 SET JND=$PIECE(DDATA("FIND"),",",IND)
- +103 SET DTYPE=DDATA("FIND",JND,JND)
- +104 SET KND=$ORDER(^PXRMXP(810.5,PLIEN,30,IEN,"DATA","B",DTYPE,""))
- +105 SET DL=$SELECT(KND="":0,1:$LENGTH(^PXRMXP(810.5,PLIEN,30,IEN,"DATA",KND,0),U))
- +106 SET DATA=$SELECT(KND="":"",1:$PIECE(^PXRMXP(810.5,PLIEN,30,IEN,"DATA",KND,0),U,2,DL))
- +107 SET ^TMP("PXRMPLD",$JOB,DFN,"FIND",JND)=DATA
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +108 ;Get appointment data for all patients on the list.
- +109 IF GETAPP
- Begin DoDot:1
- +110 NEW APPLIST,ARRAY,COUNT,DONE
- +111 SET ARRAY(1)=DT
- SET ARRAY(3)="I;R"
- SET ARRAY(4)="^TMP($J,""PXRMPL"""
- +112 SET ARRAY("FLDS")=""
- +113 FOR IND=1:1:DDATA("APP","LEN")
- Begin DoDot:2
- +114 SET JND=$PIECE(DDATA("APP"),",",IND)
- +115 SET KND=0
- +116 FOR
- SET KND=$ORDER(DDATA("APP",JND,KND))
- if KND=""
- QUIT
- SET ARRAY("FLDS")=ARRAY("FLDS")_KND_";"
- End DoDot:2
- +117 KILL ^TMP($JOB,"PXRMPL"),^TMP($JOB,"SDAMA301")
- +118 SET IND=0
- +119 FOR
- SET IND=+$ORDER(^PXRMXP(810.5,PLIEN,30,IND))
- if IND=0
- QUIT
- Begin DoDot:2
- +120 SET DFN=$PIECE(^PXRMXP(810.5,PLIEN,30,IND,0),U,1)
- +121 IF DFN'=""
- SET ^TMP($JOB,"PXRMPL",DFN)=""
- End DoDot:2
- +122 SET COUNT=$$SDAPI^SDAMA301(.ARRAY)
- +123 IF COUNT=-1
- Begin DoDot:2
- +124 DO APPERR^PXRMPDRS
- +125 SET DDATA("APP","ERROR")=""
- +126 KILL ^TMP($JOB,"PXRMPL"),^TMP($JOB,"SDAMA301")
- End DoDot:2
- QUIT
- +127 ;Data is ^TMP($J,"SDAMA301",DFN,CLINIC,DATE)=DATE^CLINIC
- +128 ;Resort by DATE then CLINIC.
- +129 SET DFN=""
- +130 FOR
- SET DFN=$ORDER(^TMP($JOB,"SDAMA301",DFN))
- if DFN=""
- QUIT
- Begin DoDot:2
- +131 KILL APPLIST
- +132 SET JND=0
- +133 FOR
- SET JND=$ORDER(^TMP($JOB,"SDAMA301",DFN,JND))
- if JND=""
- QUIT
- Begin DoDot:3
- +134 SET DATE=0
- +135 FOR
- SET DATE=$ORDER(^TMP($JOB,"SDAMA301",DFN,JND,DATE))
- if DATE=""
- QUIT
- SET APPLIST(DATE,JND)=""
- End DoDot:3
- +136 SET (DATE,DONE,KND)=0
- +137 FOR
- SET DATE=$ORDER(APPLIST(DATE))
- if (DONE)!(DATE="")
- QUIT
- Begin DoDot:3
- +138 SET JND=0
- +139 FOR
- SET JND=$ORDER(APPLIST(DATE,JND))
- if (DONE)!(JND="")
- QUIT
- Begin DoDot:4
- +140 SET KND=KND+1
- +141 IF KND=DDATA("APP","MAX")
- SET DONE=1
- +142 SET TDATA=^TMP($JOB,"SDAMA301",DFN,JND,DATE)
- +143 SET PDATA=$$FMTE^XLFDT($PIECE(TDATA,U,1))
- +144 SET TDATA=$PIECE(TDATA,U,2)
- SET TDATA=$PIECE(TDATA,";",2)
- +145 SET PDATA=PDATA_U_TDATA
- +146 SET ^TMP("PXRMPLD",$JOB,DFN,"APP",KND)=PDATA
- End DoDot:4
- End DoDot:3
- End DoDot:2
- +147 KILL ^TMP($JOB,"PXRMPL"),^TMP($JOB,"SDAMA301")
- End DoDot:1
- +148 IF DELIM=1
- DO DELIMPR^PXRMPDRP(DC,PLIEN,.DDATA)
- +149 IF DELIM=0
- DO REGPR^PXRMPDRP(PLIEN,.DDATA)
- +150 QUIT
- +151 ;
- LENGTH(STR,STR1) ;
- +1 IF ($LENGTH(STR)+$LENGTH(STR1))>245
- WRITE !,STR
- SET STR=STR1
- +2 IF '$TEST
- SET STR=STR_U_STR1
- SET STR1=""
- +3 QUIT
- +4 ;