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

DGPPRP1.m

Go to the documentation of this file.
  1. DGPPRP1 ;LIB/MKN - PRESUMPTIVE PSYCHOSIS STATUS REPORT;08/01/2019
  1. ;;5.3;Registration;**977**August 01, 2019;;Build 177
  1. ;
  1. ;IA's
  1. ; 402 Ctrl ^SCE("ADFN"
  1. ; 664 Sup DIVISION^VAUTOMA
  1. ; 2171 Sup ^XUAF4; $$STA
  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, $$NOW
  1. ; 10112 Sup ^VASITE: $$SITE
  1. ; 10141 Sup ^XPDUTL $$INSTALDT
  1. ;
  1. Q
  1. ;
  1. EN ;entry point from Menu Option: PRESUMPTIVE PSYCHOSIS STATUS REPORT
  1. N DFN,DGCAT,DGDIV,DGDIVSEL,DGDT,DGDTDEF,DGDTF,DGDTP,DGDTT,DGRTYP,DGRES,DGSET,DGSRTFAC,DGTEMP,DGX,DGYN,PAGE,POP,VAUTD,Y,ZTDESC,ZTRTN,ZTSAVE,ZTSK,%ZIS
  1. S DGDTDEF=$$GETDEFD() I DGDTDEF="" W !!,"There is no record of patch DG*5.3*977 being installed!",!! Q
  1. ;DG*5.3*977 PP
  1. W @IOF
  1. W !,"PRESUMPTIVE PSYCHOSIS STATUS REPORT"
  1. ;PRESUMPTIVE PSYCHOSIS STATUS REPORT help text
  1. D HELP^DGPPRP3(1)
  1. ASKDIV ;Select Division
  1. S DGX=$$SELDIV(.DGDIVSEL) Q:'DGX
  1. S DGSRTFAC=0 I DGDIVSEL S DIR(0)="Y",DIR("A")="Do you want to sort by division",DIR("B")="Y" D ^DIR Q:Y=U I 'Y S DGSRTFAC=+$$SITE^VASITE()
  1. ;
  1. SELCAT ;
  1. S DGSET="S^ALL:ALL;"_$P($G(^DD(2,.5601,0)),U,3)
  1. I $P(DGSET,U,2)="" W !,"Presumptive Psychosis Category not found in Patient file" Q
  1. S DGRTYP=$$SELECT("Select One of the Following:",DGSET)
  1. I Y="^" Q ;quit if no selection
  1. ;
  1. SELDATES ;
  1. N DGDTFC,DGDTTC
  1. S DGDT=$$DTFRMTO("Select dates")
  1. Q:+DGDT=0 S DGDTF=$P(DGDT,U,2),DGDTT=$P(DGDT,U,3)_".2399"
  1. S DGDTFC=$$FMTE^XLFDT(DGDTF,"5PZ"),DGDTTC=$$FMTE^XLFDT(DGDTT,"5PZ")
  1. S DGTEMP=$NA(^TMP("DGPPRP1",$J)) K @DGTEMP
  1. ; Allow queueing
  1. K IOP,IO("Q") S %ZIS="MQ",%ZIS("B")="",POP=0 D ^%ZIS Q:POP
  1. I $D(IO("Q")) D Q ;Queued report settings
  1. .S ZTDESC="Presumptive Psychosis Report",ZTRTN="DQ^DGPPRP1"
  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. ;
  1. DQ ;
  1. N DFN,DFNA,DGN,IENDFN,EXIT
  1. S EXIT=0
  1. S DGDTP="Date Printed: "_$$FMTE^XLFDT($$NOW^XLFDT()\1,"5PZ")
  1. S DGDT=$$FMADD^XLFDT(DGDTF,-1)_".2399" F S DGDT=$O(^DGPP(33.1,"AC",DGDT)) Q:'DGDT!(DGDT>DGDTT) D
  1. . S DGCAT="" F S DGCAT=$O(^DGPP(33.1,"AC",DGDT,DGCAT)) Q:DGCAT="" D
  1. .. S DGYN=0 I DGRTYP="ALL" S DGYN=1 ;If all categories selected
  1. .. I 'DGYN,DGCAT=DGRTYP S DGYN=1 ;If selected category match
  1. .. Q:'DGYN
  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. ... S DGN=$O(^DGPP(33.1,"AC",DGDT,DGCAT,IENDFN,"")) Q:'DGN
  1. ... D:'$D(DFNA(DFN)) SET(IENDFN,DGDT,DGDTF,DGDTT,.DGDIVSEL)
  1. ... S DFNA(DFN)=""
  1. D PRINT,OUT
  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. PRINT ;Print results by Division/PP Category/Treatment Date/Patient Name
  1. N DASH,DFN,DGCAT,DGCATL,DGDT,DGHDRDT,DGHDRYN,DGI,DGPATNA,DGX,DGY,LASTPNA
  1. W @IOF I '$D(@DGTEMP) W !!?10," << None found >> ",!! G OUT
  1. S DGX=$P(^DD(2,.5601,0),U,3),PAGE=0 K DGCATL F DGI=1:1:$L(DGX,";")-1 S DGY=$P(DGX,";",DGI),DGCATL($P(DGY,":"))=$P(DGY,":",2)
  1. S DGHDRDT="Date Range: "_$$FMTE^XLFDT(DGDTF,"5PZ")_" to "_$$FMTE^XLFDT((DGDTT\1),"5PZ")
  1. S DASH="",$P(DASH,"-",81)="",(DGHDRYN,EXIT)=0
  1. S DGDIV="" F S DGDIV=$O(@DGTEMP@(DGDIV)) Q:DGDIV=""!(EXIT) S DGHDRYN=1 D
  1. . S LASTPNA=""
  1. . S DGPATNA="" F S DGPATNA=$O(@DGTEMP@(DGDIV,DGPATNA)) Q:DGPATNA=""!(EXIT) D
  1. .. S DFN="" F S DFN=$O(@DGTEMP@(DGDIV,DGPATNA,DFN)) Q:DFN=""!(EXIT) D
  1. ... S DGDT="" F S DGDT=$O(@DGTEMP@(DGDIV,DGPATNA,DFN,DGDT),-1) Q:DGDT=""!(EXIT) D PRINT2 Q:EXIT
  1. W !
  1. Q
  1. ;
  1. PRINT2 ;
  1. N DGCAT,DGDT1,DGSTA
  1. S DGDT1=0 F S DGDT1=$O(@DGTEMP@(DGDIV,DGPATNA,DFN,DGDT,DGDT1)) Q:'DGDT1!EXIT D
  1. .S DGCAT="" F S DGCAT=$O(@DGTEMP@(DGDIV,DGPATNA,DFN,DGDT,DGDT1,DGCAT)) Q:DGCAT=""!EXIT D
  1. ..S DGX=@DGTEMP@(DGDIV,DGPATNA,DFN,DGDT,DGDT1,DGCAT),DGSTA=$P(DGX,U,2)
  1. ..I $Y+2>IOSL!DGHDRYN,PAGE>0 I ($E(IOST,1,2)="C-")&(IO=IO(0)) W ! S DIR(0)="E" D ^DIR K DIR D Q:EXIT
  1. ...I $D(DTOUT)!($D(DUOUT)) S EXIT=1 Q
  1. ...W @IOF D HDR S DGHDRYN=0
  1. ...Q
  1. ..D:DGHDRYN HDR W ! W:(LASTPNA="")!(LASTPNA]""&(LASTPNA'=DGPATNA)) $E(DGPATNA,1,20),?22,$P(DGX,U) W ?28,DGCATL(DGCAT),?57,$$FMTE^XLFDT(DGDT\1)
  1. ..S LASTPNA=DGPATNA
  1. ..Q
  1. .Q
  1. Q
  1. ;
  1. HDR ; Print page header
  1. N DGX
  1. S PAGE=PAGE+1,DGX="Presumptive Psychosis Status Report"
  1. W $J(" ",80-$L(DGX)/2),DGX
  1. W !,$J(" ",80-$L(DGHDRDT)/2),DGHDRDT
  1. S DGX=$S(DGSRTFAC=0:"Division",1:"Facility")_": "_$$GET1^DIQ(40.8,DGDIV_",",.01)_" ("_DGSTA_")"
  1. W !,$J(" ",80-$L(DGX)/2),DGX
  1. W !,$J(" ",80-$L(DGDTP)/2-1),DGDTP
  1. W !!?68,"Page: ",PAGE,!,DASH
  1. W !,"PATIENT NAME",?22,"PID",?28,"PRESUMPTIVE PSYCHOSIS CAT.",?57,"STATUS DATE"
  1. W !,DASH
  1. S DGHDRYN=0
  1. Q
  1. ;
  1. SET(IENDFN,DGDT,FD,TD,VAUTD) ;
  1. N DGCAT,DGDIV,DGDT1,DFN,DFNS,DGI,DGIENS,DGOUT,DGPAT,DGRET,DGSTD,DGSUB1,DGX,DGY,IENDFNS
  1. S DFN=$P(^DGPP(33.1,IENDFN,0),U),DFNS=DFN_","
  1. D CHKTREAT(.DGRET,DFN,FD,TD,.DGDIVSEL) Q:'$D(DGRET)
  1. S IENDFNS=IENDFN_"," D GETS^DIQ(2,DFNS,".01;.0905","E","DGPAT")
  1. S DGDIV="" F S DGDIV=$O(DGRET(DGDIV)) Q:DGDIV="" D
  1. . S DGDT1=0 F S DGDT1=$O(DGRET(DGDIV,DGDT1)) Q:'DGDT1 D
  1. .. K DGOUT D GETS^DIQ(33.1,IENDFN_",","**","IE","DGOUT")
  1. .. F DGI=1:1 S DGIENS=DGI_","_IENDFN_"," Q:'$D(DGOUT(33.12,DGIENS)) D
  1. ... S DGCAT=DGOUT(33.12,DGIENS,.02,"I") Q:($G(DGRTYP)'=""&($G(DGRTYP)'="ALL")&(DGRTYP'=DGCAT))!(DGCAT="")
  1. ... S DGSUB1=$S(DGSRTFAC:DGSRTFAC,1:DGDIV)
  1. ... S @DGTEMP@(DGSUB1,DGPAT(2,DFNS,.01,"E"),DFN,$G(DGOUT(33.12,DGIENS,.01,"I")),DGDT,DGCAT)=$G(DGPAT(2,DFNS,.0905,"E"))_U_$P(DGRET(DGDIV,DGDT1),U,2)
  1. Q
  1. ;
  1. SELDIV(DGDIVSEL) ;prompt for DIVISION
  1. N DIV,FAC,VAUTD,Y
  1. W !
  1. I '$D(^DG(40.8,+$O(^DG(40.8,0)),0)) D Q 0
  1. . W !!,*7,"***WARNING...MEDICAL CENTER DIVISION FILE IS NOT SET UP",!
  1. ;get division
  1. D DIVISION^VAUTOMA
  1. Q:$G(Y)<0 0
  1. M DGDIVSEL=VAUTD
  1. Q 1
  1. ;
  1. ;Check if patient should be included in report, using OUTPATIENT ENCOUNTER file, and return division
  1. CHKTREAT(RET,DFN,DGDTF,DGDTT,ARRDIV) ;
  1. ;
  1. ;Find all divisions within the user-selected date range, and check input array ARRDIV
  1. ;
  1. ;Input:
  1. ; DFN=IEN in file #2
  1. ; DGDTF='From' date entered by user
  1. ; DGDTT='To' date entered by user
  1. ; ARRDIV is in the format output by utility VAUTOMA
  1. ;Output:
  1. ; RET(DIVISION#,DATE OF ENCOUNTER)=Name of division^Station #
  1. ; Example:
  1. ; RET(1,3190425)="NORTHAMPTON^666"
  1. ; RET(7,3190413)="PITTSFIELD^777"
  1. ; RET(7,3190425)="PITTSFIELD^888"
  1. ;
  1. N DGCO,DGDIV,DGDT,DGIEN,DGOUT
  1. S DGDT="" F S DGDT=$O(^SCE("ADFN",DFN,DGDT),-1) Q:'DGDT!(DGDT<DGDTF) D:(DGDT\1'<DGDTF)&((DGDT\1)'>DGDTT)
  1. . S DGIEN=0 F S DGIEN=$O(^SCE("ADFN",DFN,DGDT,DGIEN)) Q:'DGIEN D
  1. .. K DGOUT D GETS^DIQ(409.68,DGIEN_",",".11;.12","IE","DGOUT") Q:$G(DGOUT(409.68,DGIEN_",",.12,"E"))'="CHECKED OUT"
  1. .. S DGDIV=$G(DGOUT(409.68,DGIEN_",",.11,"I")) Q:DGDIV=""
  1. .. S DGSTA=$$STA^XUAF4($$GET1^DIQ(40.8,DGDIV_",",.07,"I"))
  1. .. I $G(ARRDIV)=1 D CHKTRSET Q
  1. .. D:$D(ARRDIV(DGDIV)) CHKTRSET
  1. Q
  1. ;
  1. CHKTRSET ;
  1. S RET(DGDIV,DGDT\1)=DGOUT(409.68,DGIEN_",",.11,"E")_U_DGSTA
  1. Q
  1. ;
  1. DTFRMTO(PROMPT) ;Get from and to dates
  1. N %DT,Y,X,DGDTFRM,DGDTTO,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. FRMDT ;
  1. S OUT=0
  1. S DIR(0)="DO^"_DT_":"_DT_":EX",%DT("B")=$$FMTE^XLFDT(DGDTDEF,"5PZ")
  1. S %DT="AEX",%DT("A")="From date: " ;Enter Beginning Date: "
  1. W ! D ^%DT K %DT
  1. Q:Y<0 0
  1. I Y<DGDTDEF W !!,"'From' date may not be earlier than "_$$FMTE^XLFDT(DGDTDEF,"5PZ") G FRMDT
  1. I Y>DT W !,"Future dates are not allowed, please re-enter",! K Y,%DT G FRMDT ;Future dates not allowed
  1. S DGDTFRM=+Y
  1. TODT ;
  1. S %DT="AEX",%DT("A")="To date: ",%DT("B")=$$FMTE^XLFDT($$NOW^XLFDT\1,"5PZ") ; Get end date, default is "TODAY"
  1. D ^%DT K %DT
  1. Q:Y<0 0
  1. I Y<DGDTFRM W !!,"'To' date may not be earlier than 'From' date" K %DT G TODT
  1. I Y>DT W !,"Future dates are not allowed, please re-enter",! K Y,%DT G TODT
  1. S DGDTTO=+Y,OUT=1_U_DGDTFRM_U_DGDTTO
  1. Q OUT
  1. ;
  1. SELECT(PROMPT,SET) ; prompts for a report type
  1. S DIR(0)=SET,DIR("A")="Please select report type",DIR("B")="ALL" D ^DIR K DIR
  1. Q:Y<0 EXIT
  1. Q Y
  1. ;
  1. GETDEFD() ;
  1. N DGOUT,X
  1. S X=$$INSTALDT^XPDUTL("DG*5.3*977",.DGOUT)
  1. Q $O(DGOUT(""))\1
  1. ;
  1. OUT ; KILL RETURN ARRAY QUIT
  1. D ^%ZISC
  1. K @DGTEMP
  1. Q
  1. ;