DGPPRP1 ;LIB/MKN - PRESUMPTIVE PSYCHOSIS STATUS REPORT;08/01/2019
;;5.3;Registration;**977**August 01, 2019;;Build 177
;
;IA's
; 402 Ctrl ^SCE("ADFN"
; 664 Sup DIVISION^VAUTOMA
; 2171 Sup ^XUAF4; $$STA
; 10003 Sup ^%DT
; 10004 Sup ^DIQ: $$GET1, GETS
; 10026 Sup ^DIR
; 10063 Sup ^%ZTLOAD
; 10086 Sup ^%ZIS: HOME
; 10089 Sup ^%ZISC
; 10103 Sup ^XLFDT: $$FMTE, $$FMADD, $$NOW
; 10112 Sup ^VASITE: $$SITE
; 10141 Sup ^XPDUTL $$INSTALDT
;
Q
;
EN ;entry point from Menu Option: PRESUMPTIVE PSYCHOSIS STATUS REPORT
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
S DGDTDEF=$$GETDEFD() I DGDTDEF="" W !!,"There is no record of patch DG*5.3*977 being installed!",!! Q
;DG*5.3*977 PP
W @IOF
W !,"PRESUMPTIVE PSYCHOSIS STATUS REPORT"
;PRESUMPTIVE PSYCHOSIS STATUS REPORT help text
D HELP^DGPPRP3(1)
ASKDIV ;Select Division
S DGX=$$SELDIV(.DGDIVSEL) Q:'DGX
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()
;
SELCAT ;
S DGSET="S^ALL:ALL;"_$P($G(^DD(2,.5601,0)),U,3)
I $P(DGSET,U,2)="" W !,"Presumptive Psychosis Category not found in Patient file" Q
S DGRTYP=$$SELECT("Select One of the Following:",DGSET)
I Y="^" Q ;quit if no selection
;
SELDATES ;
N DGDTFC,DGDTTC
S DGDT=$$DTFRMTO("Select dates")
Q:+DGDT=0 S DGDTF=$P(DGDT,U,2),DGDTT=$P(DGDT,U,3)_".2399"
S DGDTFC=$$FMTE^XLFDT(DGDTF,"5PZ"),DGDTTC=$$FMTE^XLFDT(DGDTT,"5PZ")
S DGTEMP=$NA(^TMP("DGPPRP1",$J)) K @DGTEMP
; Allow queueing
K IOP,IO("Q") S %ZIS="MQ",%ZIS("B")="",POP=0 D ^%ZIS Q:POP
I $D(IO("Q")) D Q ;Queued report settings
.S ZTDESC="Presumptive Psychosis Report",ZTRTN="DQ^DGPPRP1"
.S ZTSAVE("DGRTYP")="",ZTSAVE("DGDTFRMT")="",ZTSAVE("DGDTFRM")="",ZTSAVE("ZTREQ")="@",ZTSAVE("DGDTTO")=""
.D ^%ZTLOAD,HOME^%ZIS
.I $G(ZTSK) W !!,"Report compilation has started with task# ",ZTSK,".",! S DIR(0)="E" D ^DIR K DIR
;
DQ ;
N DFN,DFNA,DGN,IENDFN,EXIT
S EXIT=0
S DGDTP="Date Printed: "_$$FMTE^XLFDT($$NOW^XLFDT()\1,"5PZ")
S DGDT=$$FMADD^XLFDT(DGDTF,-1)_".2399" F S DGDT=$O(^DGPP(33.1,"AC",DGDT)) Q:'DGDT!(DGDT>DGDTT) D
. S DGCAT="" F S DGCAT=$O(^DGPP(33.1,"AC",DGDT,DGCAT)) Q:DGCAT="" D
.. S DGYN=0 I DGRTYP="ALL" S DGYN=1 ;If all categories selected
.. I 'DGYN,DGCAT=DGRTYP S DGYN=1 ;If selected category match
.. Q:'DGYN
.. S IENDFN=0 F S IENDFN=$O(^DGPP(33.1,"AC",DGDT,DGCAT,IENDFN)) Q:'IENDFN D
... S DFN=$P($G(^DGPP(33.1,IENDFN,0)),U) Q:'DFN
... S DGN=$O(^DGPP(33.1,"AC",DGDT,DGCAT,IENDFN,"")) Q:'DGN
... D:'$D(DFNA(DFN)) SET(IENDFN,DGDT,DGDTF,DGDTT,.DGDIVSEL)
... S DFNA(DFN)=""
D PRINT,OUT
I $E(IOST,1,2)="C-",'EXIT R !!?8,"End of the Report...Press Enter to Continue",X:DTIME W @IOF
Q
;
PRINT ;Print results by Division/PP Category/Treatment Date/Patient Name
N DASH,DFN,DGCAT,DGCATL,DGDT,DGHDRDT,DGHDRYN,DGI,DGPATNA,DGX,DGY,LASTPNA
W @IOF I '$D(@DGTEMP) W !!?10," << None found >> ",!! G OUT
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)
S DGHDRDT="Date Range: "_$$FMTE^XLFDT(DGDTF,"5PZ")_" to "_$$FMTE^XLFDT((DGDTT\1),"5PZ")
S DASH="",$P(DASH,"-",81)="",(DGHDRYN,EXIT)=0
S DGDIV="" F S DGDIV=$O(@DGTEMP@(DGDIV)) Q:DGDIV=""!(EXIT) S DGHDRYN=1 D
. S LASTPNA=""
. S DGPATNA="" F S DGPATNA=$O(@DGTEMP@(DGDIV,DGPATNA)) Q:DGPATNA=""!(EXIT) D
.. S DFN="" F S DFN=$O(@DGTEMP@(DGDIV,DGPATNA,DFN)) Q:DFN=""!(EXIT) D
... S DGDT="" F S DGDT=$O(@DGTEMP@(DGDIV,DGPATNA,DFN,DGDT),-1) Q:DGDT=""!(EXIT) D PRINT2 Q:EXIT
W !
Q
;
PRINT2 ;
N DGCAT,DGDT1,DGSTA
S DGDT1=0 F S DGDT1=$O(@DGTEMP@(DGDIV,DGPATNA,DFN,DGDT,DGDT1)) Q:'DGDT1!EXIT D
.S DGCAT="" F S DGCAT=$O(@DGTEMP@(DGDIV,DGPATNA,DFN,DGDT,DGDT1,DGCAT)) Q:DGCAT=""!EXIT D
..S DGX=@DGTEMP@(DGDIV,DGPATNA,DFN,DGDT,DGDT1,DGCAT),DGSTA=$P(DGX,U,2)
..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
...I $D(DTOUT)!($D(DUOUT)) S EXIT=1 Q
...W @IOF D HDR S DGHDRYN=0
...Q
..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)
..S LASTPNA=DGPATNA
..Q
.Q
Q
;
HDR ; Print page header
N DGX
S PAGE=PAGE+1,DGX="Presumptive Psychosis Status Report"
W $J(" ",80-$L(DGX)/2),DGX
W !,$J(" ",80-$L(DGHDRDT)/2),DGHDRDT
S DGX=$S(DGSRTFAC=0:"Division",1:"Facility")_": "_$$GET1^DIQ(40.8,DGDIV_",",.01)_" ("_DGSTA_")"
W !,$J(" ",80-$L(DGX)/2),DGX
W !,$J(" ",80-$L(DGDTP)/2-1),DGDTP
W !!?68,"Page: ",PAGE,!,DASH
W !,"PATIENT NAME",?22,"PID",?28,"PRESUMPTIVE PSYCHOSIS CAT.",?57,"STATUS DATE"
W !,DASH
S DGHDRYN=0
Q
;
SET(IENDFN,DGDT,FD,TD,VAUTD) ;
N DGCAT,DGDIV,DGDT1,DFN,DFNS,DGI,DGIENS,DGOUT,DGPAT,DGRET,DGSTD,DGSUB1,DGX,DGY,IENDFNS
S DFN=$P(^DGPP(33.1,IENDFN,0),U),DFNS=DFN_","
D CHKTREAT(.DGRET,DFN,FD,TD,.DGDIVSEL) Q:'$D(DGRET)
S IENDFNS=IENDFN_"," D GETS^DIQ(2,DFNS,".01;.0905","E","DGPAT")
S DGDIV="" F S DGDIV=$O(DGRET(DGDIV)) Q:DGDIV="" D
. S DGDT1=0 F S DGDT1=$O(DGRET(DGDIV,DGDT1)) Q:'DGDT1 D
.. K DGOUT D GETS^DIQ(33.1,IENDFN_",","**","IE","DGOUT")
.. F DGI=1:1 S DGIENS=DGI_","_IENDFN_"," Q:'$D(DGOUT(33.12,DGIENS)) D
... S DGCAT=DGOUT(33.12,DGIENS,.02,"I") Q:($G(DGRTYP)'=""&($G(DGRTYP)'="ALL")&(DGRTYP'=DGCAT))!(DGCAT="")
... S DGSUB1=$S(DGSRTFAC:DGSRTFAC,1:DGDIV)
... 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)
Q
;
SELDIV(DGDIVSEL) ;prompt for DIVISION
N DIV,FAC,VAUTD,Y
W !
I '$D(^DG(40.8,+$O(^DG(40.8,0)),0)) D Q 0
. W !!,*7,"***WARNING...MEDICAL CENTER DIVISION FILE IS NOT SET UP",!
;get division
D DIVISION^VAUTOMA
Q:$G(Y)<0 0
M DGDIVSEL=VAUTD
Q 1
;
;Check if patient should be included in report, using OUTPATIENT ENCOUNTER file, and return division
CHKTREAT(RET,DFN,DGDTF,DGDTT,ARRDIV) ;
;
;Find all divisions within the user-selected date range, and check input array ARRDIV
;
;Input:
; DFN=IEN in file #2
; DGDTF='From' date entered by user
; DGDTT='To' date entered by user
; ARRDIV is in the format output by utility VAUTOMA
;Output:
; RET(DIVISION#,DATE OF ENCOUNTER)=Name of division^Station #
; Example:
; RET(1,3190425)="NORTHAMPTON^666"
; RET(7,3190413)="PITTSFIELD^777"
; RET(7,3190425)="PITTSFIELD^888"
;
N DGCO,DGDIV,DGDT,DGIEN,DGOUT
S DGDT="" F S DGDT=$O(^SCE("ADFN",DFN,DGDT),-1) Q:'DGDT!(DGDT<DGDTF) D:(DGDT\1'<DGDTF)&((DGDT\1)'>DGDTT)
. S DGIEN=0 F S DGIEN=$O(^SCE("ADFN",DFN,DGDT,DGIEN)) Q:'DGIEN D
.. K DGOUT D GETS^DIQ(409.68,DGIEN_",",".11;.12","IE","DGOUT") Q:$G(DGOUT(409.68,DGIEN_",",.12,"E"))'="CHECKED OUT"
.. S DGDIV=$G(DGOUT(409.68,DGIEN_",",.11,"I")) Q:DGDIV=""
.. S DGSTA=$$STA^XUAF4($$GET1^DIQ(40.8,DGDIV_",",.07,"I"))
.. I $G(ARRDIV)=1 D CHKTRSET Q
.. D:$D(ARRDIV(DGDIV)) CHKTRSET
Q
;
CHKTRSET ;
S RET(DGDIV,DGDT\1)=DGOUT(409.68,DGIEN_",",.11,"E")_U_DGSTA
Q
;
DTFRMTO(PROMPT) ;Get from and to dates
N %DT,Y,X,DGDTFRM,DGDTTO,DTOUT,OUT,DIRUT,DUOUT,STATUS,STDT,STATUS
;INPUT : PROMPT - Message to display prior to prompting for dates
;OUTPUT: 1^BEGDT^ENDDT - Data found
; 0 - User up arrowed or timed out
;If they want to show first available date for that set of Status, use this sub
FRMDT ;
S OUT=0
S DIR(0)="DO^"_DT_":"_DT_":EX",%DT("B")=$$FMTE^XLFDT(DGDTDEF,"5PZ")
S %DT="AEX",%DT("A")="From date: " ;Enter Beginning Date: "
W ! D ^%DT K %DT
Q:Y<0 0
I Y<DGDTDEF W !!,"'From' date may not be earlier than "_$$FMTE^XLFDT(DGDTDEF,"5PZ") G FRMDT
I Y>DT W !,"Future dates are not allowed, please re-enter",! K Y,%DT G FRMDT ;Future dates not allowed
S DGDTFRM=+Y
TODT ;
S %DT="AEX",%DT("A")="To date: ",%DT("B")=$$FMTE^XLFDT($$NOW^XLFDT\1,"5PZ") ; Get end date, default is "TODAY"
D ^%DT K %DT
Q:Y<0 0
I Y<DGDTFRM W !!,"'To' date may not be earlier than 'From' date" K %DT G TODT
I Y>DT W !,"Future dates are not allowed, please re-enter",! K Y,%DT G TODT
S DGDTTO=+Y,OUT=1_U_DGDTFRM_U_DGDTTO
Q OUT
;
SELECT(PROMPT,SET) ; prompts for a report type
S DIR(0)=SET,DIR("A")="Please select report type",DIR("B")="ALL" D ^DIR K DIR
Q:Y<0 EXIT
Q Y
;
GETDEFD() ;
N DGOUT,X
S X=$$INSTALDT^XPDUTL("DG*5.3*977",.DGOUT)
Q $O(DGOUT(""))\1
;
OUT ; KILL RETURN ARRAY QUIT
D ^%ZISC
K @DGTEMP
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPPRP1 8556 printed Dec 13, 2024@02:50:52 Page 2
DGPPRP1 ;LIB/MKN - PRESUMPTIVE PSYCHOSIS STATUS REPORT;08/01/2019
+1 ;;5.3;Registration;**977**August 01, 2019;;Build 177
+2 ;
+3 ;IA's
+4 ; 402 Ctrl ^SCE("ADFN"
+5 ; 664 Sup DIVISION^VAUTOMA
+6 ; 2171 Sup ^XUAF4; $$STA
+7 ; 10003 Sup ^%DT
+8 ; 10004 Sup ^DIQ: $$GET1, GETS
+9 ; 10026 Sup ^DIR
+10 ; 10063 Sup ^%ZTLOAD
+11 ; 10086 Sup ^%ZIS: HOME
+12 ; 10089 Sup ^%ZISC
+13 ; 10103 Sup ^XLFDT: $$FMTE, $$FMADD, $$NOW
+14 ; 10112 Sup ^VASITE: $$SITE
+15 ; 10141 Sup ^XPDUTL $$INSTALDT
+16 ;
+17 QUIT
+18 ;
EN ;entry point from Menu Option: PRESUMPTIVE PSYCHOSIS STATUS REPORT
+1 NEW 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
+2 SET DGDTDEF=$$GETDEFD()
IF DGDTDEF=""
WRITE !!,"There is no record of patch DG*5.3*977 being installed!",!!
QUIT
+3 ;DG*5.3*977 PP
+4 WRITE @IOF
+5 WRITE !,"PRESUMPTIVE PSYCHOSIS STATUS REPORT"
+6 ;PRESUMPTIVE PSYCHOSIS STATUS REPORT help text
+7 DO HELP^DGPPRP3(1)
ASKDIV ;Select Division
+1 SET DGX=$$SELDIV(.DGDIVSEL)
if 'DGX
QUIT
+2 SET DGSRTFAC=0
IF DGDIVSEL
SET DIR(0)="Y"
SET DIR("A")="Do you want to sort by division"
SET DIR("B")="Y"
DO ^DIR
if Y=U
QUIT
IF 'Y
SET DGSRTFAC=+$$SITE^VASITE()
+3 ;
SELCAT ;
+1 SET DGSET="S^ALL:ALL;"_$PIECE($GET(^DD(2,.5601,0)),U,3)
+2 IF $PIECE(DGSET,U,2)=""
WRITE !,"Presumptive Psychosis Category not found in Patient file"
QUIT
+3 SET DGRTYP=$$SELECT("Select One of the Following:",DGSET)
+4 ;quit if no selection
IF Y="^"
QUIT
+5 ;
SELDATES ;
+1 NEW DGDTFC,DGDTTC
+2 SET DGDT=$$DTFRMTO("Select dates")
+3 if +DGDT=0
QUIT
SET DGDTF=$PIECE(DGDT,U,2)
SET DGDTT=$PIECE(DGDT,U,3)_".2399"
+4 SET DGDTFC=$$FMTE^XLFDT(DGDTF,"5PZ")
SET DGDTTC=$$FMTE^XLFDT(DGDTT,"5PZ")
+5 SET DGTEMP=$NAME(^TMP("DGPPRP1",$JOB))
KILL @DGTEMP
+6 ; Allow queueing
+7 KILL IOP,IO("Q")
SET %ZIS="MQ"
SET %ZIS("B")=""
SET POP=0
DO ^%ZIS
if POP
QUIT
+8 ;Queued report settings
IF $DATA(IO("Q"))
Begin DoDot:1
+9 SET ZTDESC="Presumptive Psychosis Report"
SET ZTRTN="DQ^DGPPRP1"
+10 SET ZTSAVE("DGRTYP")=""
SET ZTSAVE("DGDTFRMT")=""
SET ZTSAVE("DGDTFRM")=""
SET ZTSAVE("ZTREQ")="@"
SET ZTSAVE("DGDTTO")=""
+11 DO ^%ZTLOAD
DO HOME^%ZIS
+12 IF $GET(ZTSK)
WRITE !!,"Report compilation has started with task# ",ZTSK,".",!
SET DIR(0)="E"
DO ^DIR
KILL DIR
End DoDot:1
QUIT
+13 ;
DQ ;
+1 NEW DFN,DFNA,DGN,IENDFN,EXIT
+2 SET EXIT=0
+3 SET DGDTP="Date Printed: "_$$FMTE^XLFDT($$NOW^XLFDT()\1,"5PZ")
+4 SET DGDT=$$FMADD^XLFDT(DGDTF,-1)_".2399"
FOR
SET DGDT=$ORDER(^DGPP(33.1,"AC",DGDT))
if 'DGDT!(DGDT>DGDTT)
QUIT
Begin DoDot:1
+5 SET DGCAT=""
FOR
SET DGCAT=$ORDER(^DGPP(33.1,"AC",DGDT,DGCAT))
if DGCAT=""
QUIT
Begin DoDot:2
+6 ;If all categories selected
SET DGYN=0
IF DGRTYP="ALL"
SET DGYN=1
+7 ;If selected category match
IF 'DGYN
IF DGCAT=DGRTYP
SET DGYN=1
+8 if 'DGYN
QUIT
+9 SET IENDFN=0
FOR
SET IENDFN=$ORDER(^DGPP(33.1,"AC",DGDT,DGCAT,IENDFN))
if 'IENDFN
QUIT
Begin DoDot:3
+10 SET DFN=$PIECE($GET(^DGPP(33.1,IENDFN,0)),U)
if 'DFN
QUIT
+11 SET DGN=$ORDER(^DGPP(33.1,"AC",DGDT,DGCAT,IENDFN,""))
if 'DGN
QUIT
+12 if '$DATA(DFNA(DFN))
DO SET(IENDFN,DGDT,DGDTF,DGDTT,.DGDIVSEL)
+13 SET DFNA(DFN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+14 DO PRINT
DO OUT
+15 IF $EXTRACT(IOST,1,2)="C-"
IF 'EXIT
READ !!?8,"End of the Report...Press Enter to Continue",X:DTIME
WRITE @IOF
+16 QUIT
+17 ;
PRINT ;Print results by Division/PP Category/Treatment Date/Patient Name
+1 NEW DASH,DFN,DGCAT,DGCATL,DGDT,DGHDRDT,DGHDRYN,DGI,DGPATNA,DGX,DGY,LASTPNA
+2 WRITE @IOF
IF '$DATA(@DGTEMP)
WRITE !!?10," << None found >> ",!!
GOTO OUT
+3 SET DGX=$PIECE(^DD(2,.5601,0),U,3)
SET PAGE=0
KILL DGCATL
FOR DGI=1:1:$LENGTH(DGX,";")-1
SET DGY=$PIECE(DGX,";",DGI)
SET DGCATL($PIECE(DGY,":"))=$PIECE(DGY,":",2)
+4 SET DGHDRDT="Date Range: "_$$FMTE^XLFDT(DGDTF,"5PZ")_" to "_$$FMTE^XLFDT((DGDTT\1),"5PZ")
+5 SET DASH=""
SET $PIECE(DASH,"-",81)=""
SET (DGHDRYN,EXIT)=0
+6 SET DGDIV=""
FOR
SET DGDIV=$ORDER(@DGTEMP@(DGDIV))
if DGDIV=""!(EXIT)
QUIT
SET DGHDRYN=1
Begin DoDot:1
+7 SET LASTPNA=""
+8 SET DGPATNA=""
FOR
SET DGPATNA=$ORDER(@DGTEMP@(DGDIV,DGPATNA))
if DGPATNA=""!(EXIT)
QUIT
Begin DoDot:2
+9 SET DFN=""
FOR
SET DFN=$ORDER(@DGTEMP@(DGDIV,DGPATNA,DFN))
if DFN=""!(EXIT)
QUIT
Begin DoDot:3
+10 SET DGDT=""
FOR
SET DGDT=$ORDER(@DGTEMP@(DGDIV,DGPATNA,DFN,DGDT),-1)
if DGDT=""!(EXIT)
QUIT
DO PRINT2
if EXIT
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+11 WRITE !
+12 QUIT
+13 ;
PRINT2 ;
+1 NEW DGCAT,DGDT1,DGSTA
+2 SET DGDT1=0
FOR
SET DGDT1=$ORDER(@DGTEMP@(DGDIV,DGPATNA,DFN,DGDT,DGDT1))
if 'DGDT1!EXIT
QUIT
Begin DoDot:1
+3 SET DGCAT=""
FOR
SET DGCAT=$ORDER(@DGTEMP@(DGDIV,DGPATNA,DFN,DGDT,DGDT1,DGCAT))
if DGCAT=""!EXIT
QUIT
Begin DoDot:2
+4 SET DGX=@DGTEMP@(DGDIV,DGPATNA,DFN,DGDT,DGDT1,DGCAT)
SET DGSTA=$PIECE(DGX,U,2)
+5 IF $Y+2>IOSL!DGHDRYN
IF PAGE>0
IF ($EXTRACT(IOST,1,2)="C-")&(IO=IO(0))
WRITE !
SET DIR(0)="E"
DO ^DIR
KILL DIR
Begin DoDot:3
+6 IF $DATA(DTOUT)!($DATA(DUOUT))
SET EXIT=1
QUIT
+7 WRITE @IOF
DO HDR
SET DGHDRYN=0
+8 QUIT
End DoDot:3
if EXIT
QUIT
+9 if DGHDRYN
DO HDR
WRITE !
if (LASTPNA="")!(LASTPNA]""&(LASTPNA'=DGPATNA))
WRITE $EXTRACT(DGPATNA,1,20),?22,$PIECE(DGX,U)
WRITE ?28,DGCATL(DGCAT),?57,$$FMTE^XLFDT(DGDT\1)
+10 SET LASTPNA=DGPATNA
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 QUIT
+14 ;
HDR ; Print page header
+1 NEW DGX
+2 SET PAGE=PAGE+1
SET DGX="Presumptive Psychosis Status Report"
+3 WRITE $JUSTIFY(" ",80-$LENGTH(DGX)/2),DGX
+4 WRITE !,$JUSTIFY(" ",80-$LENGTH(DGHDRDT)/2),DGHDRDT
+5 SET DGX=$SELECT(DGSRTFAC=0:"Division",1:"Facility")_": "_$$GET1^DIQ(40.8,DGDIV_",",.01)_" ("_DGSTA_")"
+6 WRITE !,$JUSTIFY(" ",80-$LENGTH(DGX)/2),DGX
+7 WRITE !,$JUSTIFY(" ",80-$LENGTH(DGDTP)/2-1),DGDTP
+8 WRITE !!?68,"Page: ",PAGE,!,DASH
+9 WRITE !,"PATIENT NAME",?22,"PID",?28,"PRESUMPTIVE PSYCHOSIS CAT.",?57,"STATUS DATE"
+10 WRITE !,DASH
+11 SET DGHDRYN=0
+12 QUIT
+13 ;
SET(IENDFN,DGDT,FD,TD,VAUTD) ;
+1 NEW DGCAT,DGDIV,DGDT1,DFN,DFNS,DGI,DGIENS,DGOUT,DGPAT,DGRET,DGSTD,DGSUB1,DGX,DGY,IENDFNS
+2 SET DFN=$PIECE(^DGPP(33.1,IENDFN,0),U)
SET DFNS=DFN_","
+3 DO CHKTREAT(.DGRET,DFN,FD,TD,.DGDIVSEL)
if '$DATA(DGRET)
QUIT
+4 SET IENDFNS=IENDFN_","
DO GETS^DIQ(2,DFNS,".01;.0905","E","DGPAT")
+5 SET DGDIV=""
FOR
SET DGDIV=$ORDER(DGRET(DGDIV))
if DGDIV=""
QUIT
Begin DoDot:1
+6 SET DGDT1=0
FOR
SET DGDT1=$ORDER(DGRET(DGDIV,DGDT1))
if 'DGDT1
QUIT
Begin DoDot:2
+7 KILL DGOUT
DO GETS^DIQ(33.1,IENDFN_",","**","IE","DGOUT")
+8 FOR DGI=1:1
SET DGIENS=DGI_","_IENDFN_","
if '$DATA(DGOUT(33.12,DGIENS))
QUIT
Begin DoDot:3
+9 SET DGCAT=DGOUT(33.12,DGIENS,.02,"I")
if ($GET(DGRTYP)'=""&($GET(DGRTYP)'="ALL")&(DGRTYP'=DGCAT))!(DGCAT="")
QUIT
+10 SET DGSUB1=$SELECT(DGSRTFAC:DGSRTFAC,1:DGDIV)
+11 SET @DGTEMP@(DGSUB1,DGPAT(2,DFNS,.01,"E"),DFN,$GET(DGOUT(33.12,DGIENS,.01,"I")),DGDT,DGCAT)=$GET(DGPAT(2,DFNS,.0905,"E"))_U_$PIECE(DGRET(DGDIV,DGDT1),U,2)
End DoDot:3
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
SELDIV(DGDIVSEL) ;prompt for DIVISION
+1 NEW DIV,FAC,VAUTD,Y
+2 WRITE !
+3 IF '$DATA(^DG(40.8,+$ORDER(^DG(40.8,0)),0))
Begin DoDot:1
+4 WRITE !!,*7,"***WARNING...MEDICAL CENTER DIVISION FILE IS NOT SET UP",!
End DoDot:1
QUIT 0
+5 ;get division
+6 DO DIVISION^VAUTOMA
+7 if $GET(Y)<0
QUIT 0
+8 MERGE DGDIVSEL=VAUTD
+9 QUIT 1
+10 ;
+11 ;Check if patient should be included in report, using OUTPATIENT ENCOUNTER file, and return division
CHKTREAT(RET,DFN,DGDTF,DGDTT,ARRDIV) ;
+1 ;
+2 ;Find all divisions within the user-selected date range, and check input array ARRDIV
+3 ;
+4 ;Input:
+5 ; DFN=IEN in file #2
+6 ; DGDTF='From' date entered by user
+7 ; DGDTT='To' date entered by user
+8 ; ARRDIV is in the format output by utility VAUTOMA
+9 ;Output:
+10 ; RET(DIVISION#,DATE OF ENCOUNTER)=Name of division^Station #
+11 ; Example:
+12 ; RET(1,3190425)="NORTHAMPTON^666"
+13 ; RET(7,3190413)="PITTSFIELD^777"
+14 ; RET(7,3190425)="PITTSFIELD^888"
+15 ;
+16 NEW DGCO,DGDIV,DGDT,DGIEN,DGOUT
+17 SET DGDT=""
FOR
SET DGDT=$ORDER(^SCE("ADFN",DFN,DGDT),-1)
if 'DGDT!(DGDT<DGDTF)
QUIT
if (DGDT\1'<DGDTF)&((DGDT\1)'>DGDTT)
Begin DoDot:1
+18 SET DGIEN=0
FOR
SET DGIEN=$ORDER(^SCE("ADFN",DFN,DGDT,DGIEN))
if 'DGIEN
QUIT
Begin DoDot:2
+19 KILL DGOUT
DO GETS^DIQ(409.68,DGIEN_",",".11;.12","IE","DGOUT")
if $GET(DGOUT(409.68,DGIEN_",",.12,"E"))'="CHECKED OUT"
QUIT
+20 SET DGDIV=$GET(DGOUT(409.68,DGIEN_",",.11,"I"))
if DGDIV=""
QUIT
+21 SET DGSTA=$$STA^XUAF4($$GET1^DIQ(40.8,DGDIV_",",.07,"I"))
+22 IF $GET(ARRDIV)=1
DO CHKTRSET
QUIT
+23 if $DATA(ARRDIV(DGDIV))
DO CHKTRSET
End DoDot:2
End DoDot:1
+24 QUIT
+25 ;
CHKTRSET ;
+1 SET RET(DGDIV,DGDT\1)=DGOUT(409.68,DGIEN_",",.11,"E")_U_DGSTA
+2 QUIT
+3 ;
DTFRMTO(PROMPT) ;Get from and to dates
+1 NEW %DT,Y,X,DGDTFRM,DGDTTO,DTOUT,OUT,DIRUT,DUOUT,STATUS,STDT,STATUS
+2 ;INPUT : PROMPT - Message to display prior to prompting for dates
+3 ;OUTPUT: 1^BEGDT^ENDDT - Data found
+4 ; 0 - User up arrowed or timed out
+5 ;If they want to show first available date for that set of Status, use this sub
FRMDT ;
+1 SET OUT=0
+2 SET DIR(0)="DO^"_DT_":"_DT_":EX"
SET %DT("B")=$$FMTE^XLFDT(DGDTDEF,"5PZ")
+3 ;Enter Beginning Date: "
SET %DT="AEX"
SET %DT("A")="From date: "
+4 WRITE !
DO ^%DT
KILL %DT
+5 if Y<0
QUIT 0
+6 IF Y<DGDTDEF
WRITE !!,"'From' date may not be earlier than "_$$FMTE^XLFDT(DGDTDEF,"5PZ")
GOTO FRMDT
+7 ;Future dates not allowed
IF Y>DT
WRITE !,"Future dates are not allowed, please re-enter",!
KILL Y,%DT
GOTO FRMDT
+8 SET DGDTFRM=+Y
TODT ;
+1 ; Get end date, default is "TODAY"
SET %DT="AEX"
SET %DT("A")="To date: "
SET %DT("B")=$$FMTE^XLFDT($$NOW^XLFDT\1,"5PZ")
+2 DO ^%DT
KILL %DT
+3 if Y<0
QUIT 0
+4 IF Y<DGDTFRM
WRITE !!,"'To' date may not be earlier than 'From' date"
KILL %DT
GOTO TODT
+5 IF Y>DT
WRITE !,"Future dates are not allowed, please re-enter",!
KILL Y,%DT
GOTO TODT
+6 SET DGDTTO=+Y
SET OUT=1_U_DGDTFRM_U_DGDTTO
+7 QUIT OUT
+8 ;
SELECT(PROMPT,SET) ; prompts for a report type
+1 SET DIR(0)=SET
SET DIR("A")="Please select report type"
SET DIR("B")="ALL"
DO ^DIR
KILL DIR
+2 if Y<0
QUIT EXIT
+3 QUIT Y
+4 ;
GETDEFD() ;
+1 NEW DGOUT,X
+2 SET X=$$INSTALDT^XPDUTL("DG*5.3*977",.DGOUT)
+3 QUIT $ORDER(DGOUT(""))\1
+4 ;
OUT ; KILL RETURN ARRAY QUIT
+1 DO ^%ZISC
+2 KILL @DGTEMP
+3 QUIT
+4 ;
