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

GMRCPSL1.m

Go to the documentation of this file. 
  1. GMRCPSL1 ;SLC/MA - Special Consult Reports;25-Jul-2012 11:14;DU
  1.  ;;3.0;CONSULT/REQUEST TRACKING;**23,22,1002,1003**;DEC 27, 1997;Build 14
  1.  ;
  1.  ; Modified - IHS/MSC/MGH - 09/20/2011 -
  1.  ; This is the main entry routine for the Consult Reports that
  1.  ; allow a user to search for consults by:  Provider, Location,
  1.  ; or Procedure.  Also the user may select a date range and
  1.  ; Consult status.
  1.  ; The routines will not let the user search on any Inter-Facility
  1.  ; information but will will use IFC when local fields are not present
  1. EN ;
  1.  ; GMRCARRY = used for entering more than one search value.
  1.  ;            This array will be used by all the diff searches.
  1.  ; GMRCDT1  = Start date
  1.  ; GMRCDT2  = Stop date
  1.  ; GMRCEND  = If equal to one end routine
  1.  ; GMRCSRCH = Indicates which field to search on
  1.  ; GMRCSTAT = Indicates which CPRS status to include
  1.  ; GMRCRPT  = 80 - 132 character report & data only output
  1.  ; GMRCBRK  = Print page break between sub-totals <Y-N>
  1.  ; GMRTST   = Include test pts or not Patch 1002
  1.  N GMRCDT1,GMRTST,GMRCDT2,GMRCARRY,GMRCSRCH,GMRCEND,GMRCSTAT,GMRCRPT,GMRCBRK
  1.  N GMRCQUIT
  1.  S (GMRCBRK,GMRCQUIT,GMRCEND)=0
  1.  S GMRCSRCH=$$GETSRCH                  ; Get search sequence
  1.  I GMRCSRCH=1 D                        ; Get Provider
  1.  . D GETPROV(.GMRCARRY) D
  1.  . . I '$D(GMRCARRY(1)) D WARNING
  1.  ;
  1.  I GMRCSRCH=2 D                        ; Get Location
  1.  . D GETLOC(.GMRCARRY) D
  1.  . . I '$D(GMRCARRY(1)) D WARNING
  1.  ;
  1.  I GMRCSRCH=3 D                        ; Get Procedure
  1.  . D GETPROC(.GMRCARRY) D
  1.  . . I '$D(GMRCARRY) D WARNING
  1.  I GMRCEND=1 K GMRCEND Q
  1.  S GMRTST=$$TESTPT^GMRCPC1() Q:GMRTST=1   ;Include test pts? Patch 1002
  1.  S GMRCRPT=$$TYPERPT Q:GMRCRPT=0       ; Get type or print
  1.  I GMRCRPT'=3 S GMRCBRK=$$PAGEBRK      ; Break between sub-totals
  1.  I GMRCBRK>1 Q
  1.  D GETDATE I GMRCQUIT Q                ; Get Date
  1.  I '$D(GMRCDT2) Q
  1.  S GMRCDT2=GMRCDT2+1
  1.  ;
  1.  ;
  1.  S GMRCSTAT=$$STS^GMRCPC1 Q:'GMRCSTAT  ; Get search CPRS status
  1.  ;
  1.  I GMRCRPT=0 Q
  1.  ;
  1.  D DEVICE                              ; Get printer device
  1.  ;
  1.  ; At this point all user input has been collected
  1.  ;
  1.  I $D(IO("Q")) D QUEUE Q
  1.  ;
  1.  ; Go build ^TMP("GMRCRPT",$J) using user input variables &
  1.  ; write report
  1.  D PRINT^GMRCPSL2(GMRCSRCH,.GMRCARRY,GMRCDT1,GMRCDT2,GMRCSTAT,GMRCRPT,GMRCBRK,GMRTST)  ;Report writer
  1.  KILL DIR,DIC,^TMP("GMRCRPT",$J)
  1.  Q
  1.  ;
  1. CHECK(GMRCDAT) ;CHECK FREE TEXT INPUT
  1.  N %DT,X,Y
  1.  I $E("ALL DATES",1,$L(GMRCDAT))=$$UP^XLFSTR(GMRCDAT) Q "ALL"
  1.  S %DT="E",X=GMRCDAT D ^%DT I Y<1 Q 0
  1.  Q +Y
  1.  I '$D(GMRCDT1) Q
  1.  I GMRCDT1="ALL" S GMRCDT1=0000000,GMRCDT2=9999999
  1.  Q
  1. DEVICE ; device for printout of entries to group update
  1.  N %ZIS,POP
  1.  I GMRCRPT=2 D
  1.  . W !!,"You must configure your terminal so that it"
  1.  . W " will support 132 character"
  1.  . W !,"emulation and reply 132 to the right margin setting if"
  1.  . W " using HOME"
  1.  . W !,"as the device."
  1.  . W !,""
  1.  I GMRCRPT=3 D
  1.  . W !!,"OK, you have selected a TABLE output format."
  1.  . W !,"You must use your personal computer's terminal emulation"
  1.  . W !,"to capture the output:"
  1.  . W !,""
  1.  . W !,"     1.  Enter at the DEVICE: HOME// prompt "";250;99999999"
  1.  . W !,"         and do not hit the enter key."
  1.  . W !,"     2.  Open a capture file within your terminal emulation program."
  1.  . W !,"     3.  Hit enter to start the down load."
  1.  . W !,"     4.  Close the capture file when the output stops."
  1.  . W !,""
  1. RETRY ;
  1.  S %ZIS="MQ"
  1.  D ^%ZIS
  1.  I POP S GMRCEND=1 Q
  1.  Q
  1.  ;
  1. GETDATE ;Get START and STOP dates
  1.  ;GMRCDT1=Start date
  1.  ;GMRCDT2=Stop date
  1.  N DTOUT,DIR,DUOUT,DIRUT,X,Y
  1. GETDATE1 ;
  1.  S DIR(0)="FA^1:45",DIR("A")="List From Starting Date (ALL): "
  1.  S DIR("B")="T-30" D ^DIR
  1.  I $D(DUOUT)!($D(DTOUT)) S GMRCQUIT=1 Q
  1.  S GMRCDT1=$$CHECK(X)
  1.  I 'GMRCDT1,GMRCDT1'="ALL" G GETDATE1
  1.  I GMRCDT1="ALL" S GMRCDT1=0,GMRCDT2=9999999 Q
  1.  K DIR
  1.  S DIR(0)="DAO^::E",DIR("A")="List To This Ending Date: " D ^DIR
  1.  I $D(DTOUT)!($D(DUOUT)) K GMRCDT1,GMRCDT2 Q
  1.  I +Y=0 W "(NOW)" S GMRCDT2=$$DT^XLFDT Q
  1.  I +Y<GMRCDT1 S GMRCDT2=GMRCDT1,GMRCDT1=+Y
  1.  S:'$D(GMRCDT2) GMRCDT2=+Y
  1.  Q
  1.  ;
  1.  ; Get a Location
  1. GETLOC(GMRCARRY) ;
  1.  ; DBIA 10040 call DIC=44
  1.  N DIC,DIR,DIRUT,DUOUT,DTOUT,X,Y,GMRCCNTR,GMRCQLOC
  1.  S GMRCCNTR=0
  1.  S DIR(0)="Y",DIR("B")="NO"
  1.  S DIR("A")="Enter 'YES' if you want all LOCATIONS"
  1.  W !,""
  1.  D ^DIR
  1.  W !,""
  1.  I Y=1 S GMRCARRY(1)="ALL"
  1.  N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
  1.  S DIR(0)="SA^L:LOCAL;R:REMOTE;B:BOTH LOCAL AND REMOTE LOCATIONS"
  1.  S DIR("A")=$S($D(GMRCARRY):"All ",1:"")_"(L)ocal, (R)emote, or (B)oth Local and Remote Locations: "
  1.  S DIR("B")="Local"
  1.  S DIR("?")="^D HELP^GMRCPSL1"
  1.  D ^DIR I $D(DIRUT) S GMRCEND=1 Q
  1.  S GMRCARRY=Y
  1.  Q:$D(GMRCARRY(1))
  1.  W !
  1.  I "LB"[GMRCARRY D
  1.  . S DIC=44,DIC(0)="AEMQ",DIC("A")="ENTER Local LOCATION: "
  1.  . F  D ^DIC Q:$D(DUOUT)!($D(DTOUT))!(Y<0)  D
  1.  . .  S GMRCCNTR=GMRCCNTR+1
  1.  . .  S GMRCARRY(GMRCCNTR)=Y_"^"_44
  1.  I "B"[GMRCARRY W !
  1.  I "RB"[GMRCARRY D
  1.  . N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
  1.  . S DIR(0)="PO^4:EMQ"
  1.  . S DIR("S")="I $$STA^XUAF4(+Y)=+$$STA^XUAF4(+Y)"
  1.  . S DIR("A")="ENTER Remote LOCATION"
  1.  . S DIR("?")="For this report, Institution file (#4) entries are considered Remote locations."
  1.  . F  D ^DIR S:$D(DTOUT) GMRCEND=1 S:$D(DUOUT) GMRCEND=1 Q:$D(DIRUT)  D
  1.  . . S GMRCCNTR=GMRCCNTR+1
  1.  . . S GMRCARRY(GMRCCNTR)=Y_"^"_4
  1.  Q
  1.  ;
  1.  ; Get a Procedure
  1. GETPROC(GMRCARRY) ;
  1.  N DIC,DIR,DIRUT,DUOUT,DTOUT,X,Y,GMRCCNTR,GMRCQPRC
  1.  S GMRCCNTR=0
  1.  S DIR(0)="Y",DIR("B")="NO"
  1.  S DIR("A")="Enter 'YES' if you want all PROCEDURES"
  1.  W !,""
  1.  D ^DIR
  1.  W !,""
  1.  I Y=1 S GMRCARRY(1)="ALL"  Q
  1.  S DIC=123.3,DIC(0)="AEMQ",DIC("A")="ENTER PROCEDURE: "
  1.  F  D ^DIC Q:$D(DUOUT)!($D(DTOUT))!(Y<0)  D
  1.  .  S GMRCCNTR=GMRCCNTR+1
  1.  .  S GMRCARRY(GMRCCNTR)=Y
  1.  Q
  1.  ;
  1.  ; Get a Provider name
  1. GETPROV(GMRCARRY) ;
  1.  ; DBIA 10060 call DIC=200
  1.  N DIC,DIRUT,DUOUT,DTOUT,X,Y,GMRCCNTR,GMRCQPRV
  1.  S GMRCCNTR=0
  1.  S DIR(0)="Y",DIR("B")="NO"
  1.  S DIR("A")="Enter 'YES' if you want all PROVIDERS"
  1.  W !,""
  1.  D ^DIR
  1.  W !,""
  1.  I Y=1 S GMRCARRY(1)="ALL"
  1.  N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
  1.  S DIR(0)="SA^L:LOCAL;R:REMOTE;B:BOTH LOCAL AND REMOTE PROVIDERS"
  1.  S DIR("A")=$S($D(GMRCARRY):"All ",1:"")_"(L)ocal, (R)emote, or (B)oth Local and Remote Providers: "
  1.  S DIR("B")="Local"
  1.  S DIR("?")="^D HELP^GMRCPSL1"
  1.  D ^DIR I $D(DIRUT) S GMRCEND=1 Q
  1.  S GMRCARRY=Y
  1.  Q:$D(GMRCARRY(1))
  1.  W !
  1.  I "LB"[GMRCARRY D
  1.  . S DIC=200,DIC(0)="AEMQ",DIC("A")="ENTER Local PROVIDER: "
  1.  . F  D ^DIC Q:$D(DUOUT)!($D(DTOUT))!(Y<0)  D
  1.  . .  S GMRCCNTR=GMRCCNTR+1
  1.  . .  S GMRCARRY(GMRCCNTR)=Y_"^"_200
  1.  I "B"[GMRCARRY W !
  1.  I "RB"[GMRCARRY D
  1.  . N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
  1.  . S DIR(0)="FO^2:40^D UP^GMRCA2 K:'$D(^GMR(123,""AIP"",X)) X"
  1.  . S DIR("?")="^D HELPR^GMRCIR,HELPR^GMRCPSL1"
  1.  . S DIR("A")="ENTER Remote PROVIDER"
  1.  . F  D ^DIR S:$D(DTOUT) GMRCEND=1 S:$D(DUOUT) GMRCEND=1 Q:$D(DIRUT)  D
  1.  . . D UP^GMRCA2 S Y=X
  1.  . . S GMRCCNTR=GMRCCNTR+1
  1.  . . S GMRCARRY(GMRCCNTR)=Y
  1.  Q
  1. HELP ; Help for location and provider prompts
  1.  W !!?3,"""Local"" refers to non-Inter-facility requests and Inter-"
  1.  W !?3,"facility requests originating locally."
  1.  W !?3,"""Remote"" only refers to Inter-facility requests originating"
  1.  W !?3,"at another site."
  1.  Q
  1. HELPR ; Help for remote provider prompt
  1.  W:$Y>(IOSL-4) @IOF
  1.  W !!?3,"Enter the ENTIRE name in proper CASE, exactly as it"
  1.  W !?3,"appears in the above list (including any credentials)."
  1.  W !?3,"Use copy/paste to avoid typing errors."
  1.  W !?3,"NO partial matches are done."
  1.  W !
  1.  Q
  1. GETSRCH() ;   What search criteria should report be in???
  1.  N DIR,Y,X
  1.  S DIR("A",1)="Enter Search criteria:"
  1.  S DIR("A",2)=""
  1.  S DIR("A",3)="                  1 = Sending Provider"
  1.  S DIR("A",4)="                  2 = Location"
  1.  S DIR("A",5)="                  3 = Procedure"
  1.  S DIR("A",6)=""
  1.  S DIR("A")="Search criteria"
  1.  S DIR("B")=1
  1.  S DIR(0)="NO^1:3"
  1.  D ^DIR
  1.  I ($D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT)) S GMRCEND=1
  1.  Q Y
  1.  ;
  1. PAGEBRK() ; Does user want page breaks between sub-totals?
  1.  N DIR
  1.  S DIR(0)="Y"
  1.  S DIR("A")="Display sort sequence & page breaks between sub-totals"
  1.  S DIR("B")="YES"
  1.  D ^DIR I $D(DIRUT) Q 2
  1.  Q +Y
  1. TYPERPT() ; Get type of report to print
  1.  N DIR
  1.  S DIR(0)="SO^1:80 column;2:132 column;3:Table Export"
  1.  S DIR("L",1)="Please select an output format from the following:"
  1.  S DIR("L",2)=""
  1.  S DIR("L",3)="1 -  80 column standard print [STANDARD]"
  1.  S DIR("L",4)="2 - 132 column standard print"
  1.  S DIR("L")="3 - Table without headers (export to another application)"
  1.  S DIR("B")=1
  1.  D ^DIR I $D(DIRUT)!(Y>3) Q 0
  1.  Q +Y
  1.  ;
  1. QUEUE ; send task for print and update
  1.  N ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTSAVE,ZTSK
  1.  S ZTRTN="PRTTSK^GMRCPSL2",ZTDESC="PRINT OF RECORDS FILE 123"
  1.  S ZTIO=ION
  1.  S ZTSAVE("GMRC*")=""
  1.  D ^%ZTLOAD I $G(ZTSK) W !,"Task # ",ZTSK
  1.  I '$G(ZTSK) W !,"Unable to queue report!  Try again later."
  1.  Q
  1. WARNING ; Let user know that they did not enter any data.
  1.  W !!,"No search criteria was entered" H 1
  1.  S GMRCEND=1
  1.  Q