Routine: PXRMLOCL

PXRMLOCL ;SLC/PKR - Handle location findings. ;02/17/2016

 ;;2.0;CLINICAL REMINDERS;**4,6,11,18,47**;Feb 04, 2005;Build 291

 ;This routine is for location list patient lists.

 ;=============================================

ALLLOCS(SUB) ;Build a list of all hospital locations associated

 ;with Visit file entries.

 N HLOC

 K ^TMP($J,SUB)

 S HLOC=""

 ;DBIA #2028

 F  S HLOC=$O(^AUPNVSIT("AHL",HLOC)) Q:HLOC=""  S ^TMP($J,SUB,HLOC)=""

 ;=============================================

EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Evaluate location term findings

 ;for patient lists. Return the list in ^TMP($J,PLIST)

 N BDT,EDT,ITEM,FILENUM,PFINDPA

 N STATUSA,TEMP,TFINDING,TFINDPA

 S FILENUM=$$GETFNUM^PXRMDATA(ENODE)

 S ITEM=""

 F  S ITEM=$O(TERMARR("E",ENODE,ITEM)) Q:+ITEM=0  D

 . S TFINDING=""

 . F  S TFINDING=$O(TERMARR("E",ENODE,ITEM,TFINDING)) Q:+TFINDING=0  D

 .. K PFINDPA,TFINDPA

 .. M TFINDPA=TERMARR(20,TFINDING)

 ..;Set the finding parameters.

 .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)

 .. D GPLIST(FILENUM,"IP",ITEM,.PFINDPA,PLIST)

 ;=============================================

FPLIST(FILENUM,HLOCL,NOCC,BDT,EDT,PLIST) ;Find patient list data for

 ;a visit to a hospital location. Return the list in ^TMP($J,PLIST).

 N BTIME,DAS,DATE,DEND,DFN,DONE,DS,ETIME,HLOC,INVBD,INVDATE,INVDT,INVED

 N NFOUND,SC,TEMP,TGLIST,TIME

 S TGLIST="FPLIST_PXRMLOCL"

 K ^TMP($J,TGLIST)

 S DEND=$S(EDT[".":EDT,1:EDT+.235959)

 ;"AHL" in Visit file is inverse date_.time instead of a full inverse

 ;date and time. For example if the date/time is 3030704.104449 then

 ;"AHL" has 6969295.104449 instead of 6969295.89555

 S INVBD=9999999-$P(BDT,".",1),BTIME="."_$P(BDT,".",2)

 S INVED=9999999-$P(DEND,".",1),ETIME="."_$P(DEND,".",2)

 S DS=INVED-.000001

 S HLOC=""

 F  S HLOC=$O(^TMP($J,HLOCL,HLOC)) Q:HLOC=""  D

 . S INVDT=DS,DONE=0

 .;DBIA #2028

 . F  S INVDT=$O(^AUPNVSIT("AHL",HLOC,INVDT)) Q:(DONE)!(INVDT="")  D

 .. S INVDATE=$P(INVDT,".",1)

 .. I INVDATE>INVBD S DONE=1 Q

 .. S TIME="."_$P(INVDT,".",2)

 .. I INVDATE=INVED,TIME>ETIME Q

 .. I INVDATE=INVBD,TIME<BTIME Q

 .. S DAS=0

 .. F  S DAS=$O(^AUPNVSIT("AHL",HLOC,INVDT,DAS)) Q:DAS=""  D

 ...;Check the associated appointment for a valid status, unless the

 ...;service category is historical.

 ... S TEMP=^AUPNVSIT(DAS,0)

 ... S SC=$P(TEMP,U,7)

 ... I (SC'="E")&('$$VAPSTAT^PXRMVSIT(DAS)) Q

 ... S DATE=$P(TEMP,U,1)

 ... S DFN=$P(TEMP,U,5)

 ... S ^TMP($J,TGLIST,DFN,INVDT,DAS)=DATE_U_HLOC_U_SC

 ;Return the NOCC most recent for each patient.

 S DFN=0

 F  S DFN=$O(^TMP($J,TGLIST,DFN)) Q:DFN=""  D

 . S (INVDT,NFOUND)=0

 . F  S INVDT=$O(^TMP($J,TGLIST,DFN,INVDT)) Q:(NFOUND=NOCC)!(INVDT="")  D

 .. S DAS=""

 .. F  S DAS=$O(^TMP($J,TGLIST,DFN,INVDT,DAS)) Q:(NFOUND=NOCC)!(DAS="")  D

 ... S NFOUND=NFOUND+1

 ... S ^TMP($J,PLIST,DFN,NFOUND)=DAS_U_^TMP($J,TGLIST,DFN,INVDT,DAS)

 K ^TMP($J,TGLIST)

 ;=============================================

GPLIST(FILENUM,SNODE,ITEM,PFINDPA,PLIST) ;Add to the patient list.

 ; Return the list in ^TMP($J,PLIST).

 ;^TMP($J,PLIST,T/F,DFN,ITEM,COUNT,FILENUM)=DAS^DATE^HLOC^VALUE

 N BDT,CASESEN,COND,CONVAL,DAS,DATE,EDT,DFN,FIEVD,FLIST

 N ICOND,IEN,IND,IPLIST,LNAME,NOCC,NFOUND,NGET,NP,SAVE,STATUSA

 N TEMP,TGLIST,TPLIST,UCIFS,VALUE,VSLIST

 S TGLIST="GPLIST_PXRMLOCL"

 ;Set the finding search parameters.

 D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)

 ;Ignore negative occurrence count, date reversal not allowed in

 ;patient lists.

 S NOCC=$S(NOCC<0:-NOCC,1:NOCC)

 D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)

 S NGET=$S(UCIFS:50,$D(STATUSA):50,1:NOCC)

 ;Get a list of unique locations.

 S LNAME=$P(^PXRMD(810.9,ITEM,0),U,1)

 I LNAME="VA-ALL LOCATIONS" D ALLLOCS("HLOCL")

 I LNAME'="VA-ALL LOCATIONS" D LOCLIST^PXRMLOCF(ITEM,"HLOCL")

 D FPLIST(FILENUM,"HLOCL",NGET,BDT,EDT,TGLIST)

 S DFN=""

 F  S DFN=$O(^TMP($J,TGLIST,DFN)) Q:DFN=""  D

 . K TPLIST

 . M TPLIST=^TMP($J,TGLIST,DFN)

 . S (IND,NFOUND)=0

 . K IPLIST

 . F  S IND=$O(TPLIST(IND)) Q:(IND="")!(NFOUND=NOCC)  D

 .. S TEMP=TPLIST(IND)

 .. S DAS=$P(TEMP,U,1)

 ..;Make sure the visit has not been deleted.

 ..;I '$$VISITOK(DAS) Q

 ..;PUT TEST HERE '$D(^AUPNVSIT(DAS)),'"AHL" Q

 .. S DATE=$P(TEMP,U,2)

 .. D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD)

 .. S VALUE=$G(FIEVD("VALUE"))

 .. S FIEVD("DATE")=DATE

 .. S CONVAL=$S(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVD),1:1)

 .. S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0)

 .. I SAVE D

 ... S NFOUND=NFOUND+1

 ... ;S IPLIST(CONVAL,DFN,NFOUND,FILENUM)=TEMP_U_VALUE

 ... S IPLIST(CONVAL,DFN,ITEM,NFOUND,FILENUM)=TEMP_U_VALUE

 . M ^TMP($J,PLIST)=IPLIST

 K ^TMP($J,"HLOCL"),^TMP($J,TGLIST)

 ;=============================================

PCSTOPL ;Print the Clinic Stop list. Called by the print template PXRM

 ;LOCATION LIST INQUIRY.

 N AMIS,CSTEXL,CSTOP,EXCLNCS,IND,JND,SKIP,TEMP

 S (IND,SKIP)=0

 F  S IND=+$O(^PXRMD(810.9,D0,40.7,IND)) Q:IND=0  D

 . S TEMP=^PXRMD(810.9,D0,40.7,IND,0)

 . S CSTOP=$P(TEMP,U,1)

 .;DBIA #557

 . S CSTOP=$P(^DIC(40.7,CSTOP,0),U,1)

 . S AMIS=$P(TEMP,U,2)

 . I SKIP W ! S SKIP=0

 . W !,?2,CSTOP,?34,AMIS

 . I $D(^PXRMD(810.9,D0,40.7,IND,1)) D

 .. S SKIP=1

 .. W !,?4,"Credit Stops to Exclude:"

 .. S JND=0

 .. F  S JND=+$O(^PXRMD(810.9,D0,40.7,IND,1,JND)) Q:JND=0  D

 ... S TEMP=$P(^PXRMD(810.9,D0,40.7,IND,1,JND,0),U,1)

 ... S TEMP=$P(^DIC(40.7,TEMP,0),U,1,2)

 ... S CSTOP=$P(TEMP,U,1)

 ... S AMIS=$P(TEMP,U,2)

 ... W !,?6,CSTOP,?38,AMIS

 . S CSTEXL=$G(^PXRMD(810.9,D0,40.7,IND,2))

 . I CSTEXL'="" D

 .. W !,?4,"Credit Stops to Exclude (LIST): ",$P(^PXRMD(810.9,CSTEXL,0),U,1)

 . S EXCLNCS=+$G(^PXRMD(810.9,D0,40.7,IND,3))

 . W !,?4,"Exclude locations with no credit stop: ",$S(EXCLNCS:"YES",1:"NO")

 . S SKIP=1

 ;=============================================

VISITOK(IEN) ;

Q 1

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMLOCL   5894     printed  Feb 18, 2025@23:12:51                                                                                                                                                                                                    Page 2

PXRMLOCL  ;SLC/PKR - Handle location findings. ;02/17/2016

 +1       ;;2.0;CLINICAL REMINDERS;**4,6,11,18,47**;Feb 04, 2005;Build 291

 +2       ;This routine is for location list patient lists.

 +3       ;=============================================

ALLLOCS(SUB) ;Build a list of all hospital locations associated

 +1       ;with Visit file entries.

 +2        NEW HLOC

 +3        KILL ^TMP($JOB,SUB)

 +4        SET HLOC=""

 +5       ;DBIA #2028

 +6        FOR

               SET HLOC=$ORDER(^AUPNVSIT("AHL",HLOC))

               if HLOC=""

                   QUIT

               SET ^TMP($JOB,SUB,HLOC)=""

 +7        QUIT

 +8       ;

 +9       ;=============================================

EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Evaluate location term findings

 +1       ;for patient lists. Return the list in ^TMP($J,PLIST)

 +2        NEW BDT,EDT,ITEM,FILENUM,PFINDPA

 +3        NEW STATUSA,TEMP,TFINDING,TFINDPA

 +4        SET FILENUM=$$GETFNUM^PXRMDATA(ENODE)

 +5        SET ITEM=""

 +6        FOR

               SET ITEM=$ORDER(TERMARR("E",ENODE,ITEM))

               if +ITEM=0

                   QUIT

               Begin DoDot:1

 +7                SET TFINDING=""

 +8                FOR

                       SET TFINDING=$ORDER(TERMARR("E",ENODE,ITEM,TFINDING))

                       if +TFINDING=0

                           QUIT

                       Begin DoDot:2

 +9                        KILL PFINDPA,TFINDPA

 +10                       MERGE TFINDPA=TERMARR(20,TFINDING)

 +11      ;Set the finding parameters.

 +12                       DO SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)

 +13                       DO GPLIST(FILENUM,"IP",ITEM,.PFINDPA,PLIST)

                       End DoDot:2

               End DoDot:1

 +14       QUIT

 +15      ;

 +16      ;=============================================

FPLIST(FILENUM,HLOCL,NOCC,BDT,EDT,PLIST) ;Find patient list data for

 +1       ;a visit to a hospital location. Return the list in ^TMP($J,PLIST).

 +2        NEW BTIME,DAS,DATE,DEND,DFN,DONE,DS,ETIME,HLOC,INVBD,INVDATE,INVDT,INVED

 +3        NEW NFOUND,SC,TEMP,TGLIST,TIME

 +4        SET TGLIST="FPLIST_PXRMLOCL"

 +5        KILL ^TMP($JOB,TGLIST)

 +6        SET DEND=$SELECT(EDT[".":EDT,1:EDT+.235959)

 +7       ;"AHL" in Visit file is inverse date_.time instead of a full inverse

 +8       ;date and time. For example if the date/time is 3030704.104449 then

 +9       ;"AHL" has 6969295.104449 instead of 6969295.89555

 +10       SET INVBD=9999999-$PIECE(BDT,".",1)

           SET BTIME="."_$PIECE(BDT,".",2)

 +11       SET INVED=9999999-$PIECE(DEND,".",1)

           SET ETIME="."_$PIECE(DEND,".",2)

 +12       SET DS=INVED-.000001

 +13       SET HLOC=""

 +14       FOR

               SET HLOC=$ORDER(^TMP($JOB,HLOCL,HLOC))

               if HLOC=""

                   QUIT

               Begin DoDot:1

 +15               SET INVDT=DS

                   SET DONE=0

 +16      ;DBIA #2028

 +17               FOR

                       SET INVDT=$ORDER(^AUPNVSIT("AHL",HLOC,INVDT))

                       if (DONE)!(INVDT="")

                           QUIT

                       Begin DoDot:2

 +18                       SET INVDATE=$PIECE(INVDT,".",1)

 +19                       IF INVDATE>INVBD

                               SET DONE=1

                               QUIT

 +20                       SET TIME="."_$PIECE(INVDT,".",2)

 +21                       IF INVDATE=INVED

                               IF TIME>ETIME

                                   QUIT

 +22                       IF INVDATE=INVBD

                               IF TIME<BTIME

                                   QUIT

 +23                       SET DAS=0

 +24                       FOR

                               SET DAS=$ORDER(^AUPNVSIT("AHL",HLOC,INVDT,DAS))

                               if DAS=""

                                   QUIT

                               Begin DoDot:3

 +25      ;Check the associated appointment for a valid status, unless the

 +26      ;service category is historical.

 +27                               SET TEMP=^AUPNVSIT(DAS,0)

 +28                               SET SC=$PIECE(TEMP,U,7)

 +29                               IF (SC'="E")&('$$VAPSTAT^PXRMVSIT(DAS))

                                       QUIT

 +30                               SET DATE=$PIECE(TEMP,U,1)

 +31                               SET DFN=$PIECE(TEMP,U,5)

 +32                               SET ^TMP($JOB,TGLIST,DFN,INVDT,DAS)=DATE_U_HLOC_U_SC

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +33      ;Return the NOCC most recent for each patient.

 +34       SET DFN=0

 +35       FOR

               SET DFN=$ORDER(^TMP($JOB,TGLIST,DFN))

               if DFN=""

                   QUIT

               Begin DoDot:1

 +36               SET (INVDT,NFOUND)=0

 +37               FOR

                       SET INVDT=$ORDER(^TMP($JOB,TGLIST,DFN,INVDT))

                       if (NFOUND=NOCC)!(INVDT="")

                           QUIT

                       Begin DoDot:2

 +38                       SET DAS=""

 +39                       FOR

                               SET DAS=$ORDER(^TMP($JOB,TGLIST,DFN,INVDT,DAS))

                               if (NFOUND=NOCC)!(DAS="")

                                   QUIT

                               Begin DoDot:3

 +40                               SET NFOUND=NFOUND+1

 +41                               SET ^TMP($JOB,PLIST,DFN,NFOUND)=DAS_U_^TMP($JOB,TGLIST,DFN,INVDT,DAS)

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +42       KILL ^TMP($JOB,TGLIST)

 +43       QUIT

 +44      ;

 +45      ;=============================================

GPLIST(FILENUM,SNODE,ITEM,PFINDPA,PLIST) ;Add to the patient list.

 +1       ; Return the list in ^TMP($J,PLIST).

 +2       ;^TMP($J,PLIST,T/F,DFN,ITEM,COUNT,FILENUM)=DAS^DATE^HLOC^VALUE

 +3        NEW BDT,CASESEN,COND,CONVAL,DAS,DATE,EDT,DFN,FIEVD,FLIST

 +4        NEW ICOND,IEN,IND,IPLIST,LNAME,NOCC,NFOUND,NGET,NP,SAVE,STATUSA

 +5        NEW TEMP,TGLIST,TPLIST,UCIFS,VALUE,VSLIST

 +6        SET TGLIST="GPLIST_PXRMLOCL"

 +7       ;Set the finding search parameters.

 +8        DO SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)

 +9       ;Ignore negative occurrence count, date reversal not allowed in

 +10      ;patient lists.

 +11       SET NOCC=$SELECT(NOCC<0:-NOCC,1:NOCC)

 +12       DO SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)

 +13       SET NGET=$SELECT(UCIFS:50,$DATA(STATUSA):50,1:NOCC)

 +14      ;Get a list of unique locations.

 +15       SET LNAME=$PIECE(^PXRMD(810.9,ITEM,0),U,1)

 +16       IF LNAME="VA-ALL LOCATIONS"

               DO ALLLOCS("HLOCL")

 +17       IF LNAME'="VA-ALL LOCATIONS"

               DO LOCLIST^PXRMLOCF(ITEM,"HLOCL")

 +18       DO FPLIST(FILENUM,"HLOCL",NGET,BDT,EDT,TGLIST)

 +19       SET DFN=""

 +20       FOR

               SET DFN=$ORDER(^TMP($JOB,TGLIST,DFN))

               if DFN=""

                   QUIT

               Begin DoDot:1

 +21               KILL TPLIST

 +22               MERGE TPLIST=^TMP($JOB,TGLIST,DFN)

 +23               SET (IND,NFOUND)=0

 +24               KILL IPLIST

 +25               FOR

                       SET IND=$ORDER(TPLIST(IND))

                       if (IND="")!(NFOUND=NOCC)

                           QUIT

                       Begin DoDot:2

 +26                       SET TEMP=TPLIST(IND)

 +27                       SET DAS=$PIECE(TEMP,U,1)

 +28      ;Make sure the visit has not been deleted.

 +29      ;I '$$VISITOK(DAS) Q

 +30      ;PUT TEST HERE '$D(^AUPNVSIT(DAS)),'"AHL" Q

 +31                       SET DATE=$PIECE(TEMP,U,2)

 +32                       DO GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD)

 +33                       SET VALUE=$GET(FIEVD("VALUE"))

 +34                       SET FIEVD("DATE")=DATE

 +35                       SET CONVAL=$SELECT(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVD),1:1)

 +36                       SET SAVE=$SELECT('UCIFS:1,(UCIFS&CONVAL):1,1:0)

 +37                       IF SAVE

                               Begin DoDot:3

 +38                               SET NFOUND=NFOUND+1

 +39      ;S IPLIST(CONVAL,DFN,NFOUND,FILENUM)=TEMP_U_VALUE

 +40                               SET IPLIST(CONVAL,DFN,ITEM,NFOUND,FILENUM)=TEMP_U_VALUE

                               End DoDot:3

                       End DoDot:2

 +41               MERGE ^TMP($JOB,PLIST)=IPLIST

               End DoDot:1

 +42       KILL ^TMP($JOB,"HLOCL"),^TMP($JOB,TGLIST)

 +43       QUIT

 +44      ;

 +45      ;=============================================

PCSTOPL   ;Print the Clinic Stop list. Called by the print template PXRM

 +1       ;LOCATION LIST INQUIRY.

 +2        NEW AMIS,CSTEXL,CSTOP,EXCLNCS,IND,JND,SKIP,TEMP

 +3        SET (IND,SKIP)=0

 +4        FOR

               SET IND=+$ORDER(^PXRMD(810.9,D0,40.7,IND))

               if IND=0

                   QUIT

               Begin DoDot:1

 +5                SET TEMP=^PXRMD(810.9,D0,40.7,IND,0)

 +6                SET CSTOP=$PIECE(TEMP,U,1)

 +7       ;DBIA #557

 +8                SET CSTOP=$PIECE(^DIC(40.7,CSTOP,0),U,1)

 +9                SET AMIS=$PIECE(TEMP,U,2)

 +10               IF SKIP

                       WRITE !

                       SET SKIP=0

 +11               WRITE !,?2,CSTOP,?34,AMIS

 +12               IF $DATA(^PXRMD(810.9,D0,40.7,IND,1))

                       Begin DoDot:2

 +13                       SET SKIP=1

 +14                       WRITE !,?4,"Credit Stops to Exclude:"

 +15                       SET JND=0

 +16                       FOR

                               SET JND=+$ORDER(^PXRMD(810.9,D0,40.7,IND,1,JND))

                               if JND=0

                                   QUIT

                               Begin DoDot:3

 +17                               SET TEMP=$PIECE(^PXRMD(810.9,D0,40.7,IND,1,JND,0),U,1)

 +18                               SET TEMP=$PIECE(^DIC(40.7,TEMP,0),U,1,2)

 +19                               SET CSTOP=$PIECE(TEMP,U,1)

 +20                               SET AMIS=$PIECE(TEMP,U,2)

 +21                               WRITE !,?6,CSTOP,?38,AMIS

                               End DoDot:3

                       End DoDot:2

 +22               SET CSTEXL=$GET(^PXRMD(810.9,D0,40.7,IND,2))

 +23               IF CSTEXL'=""

                       Begin DoDot:2

 +24                       WRITE !,?4,"Credit Stops to Exclude (LIST): ",$PIECE(^PXRMD(810.9,CSTEXL,0),U,1)

                       End DoDot:2

 +25               SET EXCLNCS=+$GET(^PXRMD(810.9,D0,40.7,IND,3))

 +26               WRITE !,?4,"Exclude locations with no credit stop: ",$SELECT(EXCLNCS:"YES",1:"NO")

 +27               SET SKIP=1

               End DoDot:1

 +28       QUIT

 +29      ;

 +30      ;=============================================

VISITOK(IEN) ;

 +1        QUIT 1

 +2       ;

PXRMLOCL.m