- 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 Jan 18, 2025@03:51:33 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 ;