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

DGPPRP3.m

Go to the documentation of this file. 
  1. DGPPRP3 ;LIB/MKN - PRESUMPTIVE PSYCHOSIS PATIENT PROFILES;08/02/2019
  1.  ;;5.3;Registration;**977**August 02, 2019;;Build 177
  1.  ;
  1.  ;IA's
  1.  ;   664 Sup DIVISION^VAUTOMA
  1.  ; 10003 Sup ^%DT
  1.  ; 10004 Sup ^DIQ:   $$GET1, GETS
  1.  ; 10026 Sup ^DIR
  1.  ; 10063 Sup ^%ZTLOAD
  1.  ; 10086 Sup ^%ZIS:  HOME
  1.  ; 10089 Sup ^%ZISC
  1.  ; 10103 Sup ^XLFDT: $$FMTE, $$FMADD
  1.  ;
  1.  Q
  1.  ;
  1. EN ;entry point from Menu Option: PRESUMPTIVE PSYCHOSIS PATIENT PROFILE REPORT
  1.  N DFN,DGCAT,DGDASH,DGDIV,DGDIVSEL,DGRET,DGDT,DGDTDEF,DGDTF,DGDTFRM,DGDTFSEL,DGDTSEL,DGDTT,DGDTTO,DGDTTSEL,DGRTYP
  1.  N DGRES,DGSAVIOM,DGSELDIV,DGSET,DGTEMP,DGYN,IENDFN,POP,VAUTD,Y,ZTDESC,ZTRTN,ZTSAVE,ZTSK,%ZIS
  1.  S DGTEMP=$NA(^TMP("DGPPRP3",$J)) K @DGTEMP
  1.  ;DG*5.3*977 PP
  1.  ;B9S3
  1.  W @IOF
  1.  W !,"PRESUMPTIVE PSYCHOSIS PATIENT PROFILE REPORT"
  1.  ;PRESUMPTIVE PSYCHOSIS PATIENT PROFILE REPORT help text
  1.  D HELP(1)
  1.  W !!,*7,!,"THIS REPORT REQUIRES 132 COLUMN OUTPUT"
  1. ASKDIV ;Select Division
  1.  Q:'$$SELDIV^DGPPRP1(.DGDIVSEL)
  1.  ;
  1.  S DGDTDEF=$$GETDEFD^DGPPRP1() I DGDTDEF="" W !!,"There is no record of patch DG*5.3*977 being installed!",!! Q
  1.  S DGDTSEL=$$DTFRMTO^DGPPRP1("Select dates") ;G:'DGDTSEL ASKDIV
  1.  Q:DGDTSEL=0
  1.  S DGDTFSEL=$P(DGDTSEL,U,2),DGDTTSEL=$P(DGDTSEL,U,3)
  1.  ; Allow queueing
  1.  K IOP,IO("Q") S %ZIS="MQ",%ZIS("B")="" S POP=0 D ^%ZIS Q:POP
  1.  I $D(IO("Q")) D  Q   ;Queued report settings
  1.  .S ZTDESC="Presumptive Psychosis Report",ZTRTN="DQ^DGPPRP3"
  1.  .S ZTSAVE("DGRTYP")="",ZTSAVE("DGDTFRMT")="",ZTSAVE("DGDTFRM")="",ZTSAVE("ZTREQ")="@",ZTSAVE("DGDTTO")=""
  1.  .D ^%ZTLOAD,HOME^%ZIS
  1.  .I $G(ZTSK) W !!,"Report compilation has started with task# ",ZTSK,".",! S DIR(0)="E" D ^DIR K DIR
  1. DQ ;
  1.  S DGDT=$$FMADD^XLFDT(DGDTFSEL,-1)_".2399" F  S DGDT=$O(^DGPP(33.1,"AC",DGDT)) Q:DGDT=""!(DGDT<DGDTFSEL&(DGDT>DGDTTSEL))  D
  1.  . S DGCAT="" F  S DGCAT=$O(^DGPP(33.1,"AC",DGDT,DGCAT)) Q:DGCAT=""  D
  1.  .. S IENDFN=0 F  S IENDFN=$O(^DGPP(33.1,"AC",DGDT,DGCAT,IENDFN)) Q:'IENDFN  D
  1.  ... S DFN=$P($G(^DGPP(33.1,IENDFN,0)),U) Q:'DFN
  1.  ... K DGRET D CHKTREAT^DGPPRP1(.DGRET,DFN,DGDTFSEL,DGDTTSEL,.DGDIVSEL) Q:'$D(DGRET)
  1.  ... S DGDIV="" F  S DGDIV=$O(DGRET(DGDIV)) Q:DGDIV=""  D DQ1
  1.  S DGDASH="",$P(DGDASH,"-",133)=""
  1.  D PRINT,OUT
  1.  I $E(IOST,1,2)="C-" R !!?8,"End of the Report...Press Enter to Continue",X:DTIME W @IOF
  1.  Q
  1.  ;
  1. DQ1 ;
  1.  N DGDT1
  1.  S DGDT1="" F  S DGDT1=$O(DGRET(DGDIV,DGDT1)) Q:DGDT1=""  D
  1.  . I DGDIVSEL=1 D SET Q  ;If all Divisions selected
  1.  . I $D(DGDIVSEL(DGDIV)) D SET  ;If selected Division match
  1.  Q
  1.  ;
  1. SET ;
  1.  N DGDISCH,DGDISCTY,DGENCAT,DGFAC,DGIEN2711,DGIEN2715,DFNS,DGN,DGOUT,DGOUTP,DGPATNA,DGPE,DGSERVDT,IEN3216,IENS3216
  1.  S DFNS=DFN_"," ;,DGPATNA=$$GET1^DIQ(2,DFNS,.01)
  1.  S IEN3216=$O(^DPT(DFN,.3216,"@"),-1),(DGDISCTY,DGSERVDT)=""
  1.  K DGOUT I IEN3216 D GETS^DIQ(2.3216,IEN3216_","_DFNS,".02;.06","IE","DGOUT") D
  1.  . S IENS3216=IEN3216_","_DFNS,DGSERVDT=$G(DGOUT(2.3216,IENS3216,.02,"I")) S:DGSERVDT?1.N DGSERVDT=$$FMTE^XLFDT(DGSERVDT,"5PZ")
  1.  . S DGDISCTY=$G(DGOUT(2.3216,IENS3216,.06,"E"))
  1.  D GETS^DIQ(2,DFNS,".01;.0905;.323;.361","","DGOUTP")
  1.  S @DGTEMP@(DGDIV,DFN)=$G(DGOUTP(2,DFNS,.01))_U_$G(DGOUTP(2,DFNS,.0905))_U_DGSERVDT_U_DGDISCTY
  1.  S @DGTEMP@(DGDIV,DFN)=@DGTEMP@(DGDIV,DFN)_U_$G(DGOUTP(2,DFNS,.323))_U_$G(DGOUTP(2,DFNS,.361))_U
  1.  S DGIEN2711=$O(^DGEN(27.11,"C",DFN,"")),DGENCAT=""
  1.  I DGIEN2711 S DGIEN2715=$$GET1^DIQ(27.11,DGIEN2711_",",.04,"I"),DGENCAT=$$GET1^DIQ(27.15,DGIEN2715_",",.02)
  1.  S @DGTEMP@(DGDIV,DFN)=@DGTEMP@(DGDIV,DFN)_DGENCAT
  1.  Q
  1.  ;
  1. PRINT ;Print out results
  1.  N DGI,DGPATNA,DGX,DGY,PAGE,EXIT,DGHDRYN
  1.  W @IOF I '$D(@DGTEMP) W !!?10," << None found >> ",!! G OUT
  1.  S (EXIT,PAGE,DGHDRYN)=0
  1.  S DGDIV="" F  S DGDIV=$O(@DGTEMP@(DGDIV)) Q:DGDIV=""!(EXIT)  D
  1.  .S DGHDRYN=1
  1.  .S DFN="" F  S DFN=$O(@DGTEMP@(DGDIV,DFN)) Q:DFN=""!(EXIT)  S DGX=@DGTEMP@(DGDIV,DFN) D PRINT2
  1.  .Q
  1.  W !
  1.  I $E(IOST,1,2)="C-",'EXIT R !!?8,"End of the Report...Press Enter to Continue",X:DTIME W @IOF
  1.  Q
  1.  ;
  1. PRINT2 ;
  1.  I $Y+5>IOSL!DGHDRYN,PAGE>0 I ($E(IOST,1,2)="C-")&(IO=IO(0)) W ! S DIR(0)="E" D ^DIR K DIR D
  1.  .I $D(DTOUT)!($D(DUOUT)) S EXIT=1 Q
  1.  .W @IOF D HDR S DGHDRYN=0
  1.  .Q
  1.  Q:EXIT
  1.  I DGHDRYN D HDR S DGHDRYN=0
  1.  W !,$E($P(DGX,U),1,20),?22,$P(DGX,U,2),?29,$$FMTE^XLFDT($P(DGX,U,3)),?43,$E($P(DGX,U,4),1,14),?58,$E($P(DGX,U,5),1,20),?81,$E($P(DGX,U,6),1,19),?103,$E($P(DGX,U,7),1,29)
  1.  Q
  1.  ;
  1. HDR ; Print page header
  1.  N DGX
  1.  S PAGE=PAGE+1
  1.  S DGX="Presumptive Psychosis Patient Profile",DGX=$J(" ",132-$L(DGX)\2)_DGX
  1.  W DGX,?120,"Page: ",PAGE
  1.  S DGX="Division: "_$$GET1^DIQ(40.8,DGDIV_",",.01),DGX=$J(" ",132-$L(DGX)\2)_DGX W !,DGX
  1.  S DGX="Date Range: "_$$FMTE^XLFDT(DGDTFSEL,"5PZ")_" to "_$$FMTE^XLFDT(DGDTTSEL,"5PZ"),DGX=$J(" ",132-$L(DGX)\2)_DGX W !,DGX
  1.  W ?104,"Date Printed: ",$$FMTE^XLFDT($P($$NOW^XLFDT(),"."))
  1.  W !,DGDASH,!,"PATIENT NAME",?22,"PID",?29,"  SERVICE",?43,"DISCHARGE",?58,"PERIOD OF SERVICE",?81,"PRIMARY ELIGIBILITY"
  1.  W ?103,"ENROLLMENT CAT",!?27,"SEPARATION DATE",?43,"  TYPE",!,DGDASH
  1.  ;
  1.  Q
  1.  ;
  1. DTFRMTO(PROMPT)  ;Get from and to dates 
  1.  N %DT,Y,X,DTOUT,OUT,DIRUT,DUOUT,STATUS,STDT,STATUS
  1.  ;INPUT ;   PROMPT - Message to display prior to prompting for dates
  1.  ;OUTPUT:     1^BEGDT^ENDDT - Data found
  1.  ;            0             - User up arrowed or timed out
  1.  ;If they want to show first available date for that set of Status, use this sub
  1. INDT ;
  1.  S OUT=0
  1.  S DIR(0)="DO^"_DT_":"_DT_":EX"
  1.  S %DT="AEX",%DT("A")="From date: " ;Enter Beginning Date: "
  1.  W ! D ^%DT K %DT
  1.  I Y<0 W !!,"No Date selected, quitting. ",!! Q OUT  ;Quit if user time out or didn't enter valid date
  1.  I Y>DT W !!,"Future dates are not allowed, please re-enter" K Y,%DT G INDT  ;Future dates not allowed
  1.  S DGDTFRM=+Y,%DT="AEX",%DT("A")="To date:   ",%DT("B")="T" ; Get end date, default is "TODAY"
  1.  D ^%DT K %DT
  1.  ;Quit if user time out or didn't enter valid date
  1.  I Y<0 W !!,"No Date selected, quitting. ",!! Q OUT
  1.  S DGDTTO=+Y,OUT=1_U_DGDTFRM_U_DGDTTO
  1.  ;Switch dates if Begin Date is more recent than End Date
  1.  S:DGDTFRM>DGDTTO OUT=1_U_DGDTTO_U_DGDTFRM
  1.  Q OUT
  1.  ;
  1.  ;DG*5.3*977 PP
  1.  ;B9S3
  1. HELP(DGSEL) ;
  1.  I DGSEL=1 D
  1.  . W !!,"This option generates a report that prints a list of all patients treated"
  1.  . W !,"under Presumptive Psychosis authority and who had an Outpatient Encounter"
  1.  . W !,"with the STATUS=CHECKED OUT for Clinic(s) associated with the selected"
  1.  . W !,"Division(s) within the user specified date range."
  1.  Q
  1.  ;
  1. OUT ; KILL RETURN ARRAY QUIT
  1.  D ^%ZISC
  1.  K @DGTEMP
  1.  Q