DGPPDRPT ;SLC/RM - PRESUMPTIVE PSYCHOSIS RECONCILIATION REPORT ; Dec 21, 2020@10:00 am
;;5.3;Registration;**1035**;Aug 13, 1993;Build 14
;
;Global References Supported by ICR# Type
;----------------- ----------------- -----------
; ^DG(391 2966 (DG is the Custodial Package) Cont. Sub.
; ^DIC(31 733 Cont. Sub.
; ^TMP($J SACC 2.3.2.5.1
;
;External References
;-------------------
; HOME^%ZIS 10086 Supported
; $$FINDCUR^DGENA 3812 (DG is the Custodial Package) Cont. Sub.
; DISP^DGIBDSP 4408 (DG is the Custodial Package) Cont. Sub.
; $$MTS^DGMTU 642 (DG is the Custodial Package) Cont. Sub.
; DIS^DGMTU 3789 (DG is the Custodial Package) Cont. Sub.
; $$RDIS^DGRPDB 4807 Supported
; ^DIC 10006 Supported
; WAIT^DICD 10024 Supported
; RECALL^DILFD 2055 Supported
; $$GET1^DIQ 2056 Supported
; $$GET1^DIQ(27.11 4947 (DG is the Custodial Package) Private
; ^DIR 10026 Supported
; $$INSUR^IBBAPI 4419 Supported
; 2^VADPT 10061 Supported
; KVAR^VADPT 10061 Supported
; $$SITE^VASITE 10112 Supported
; $$FMTE^XLFDT 10103 Supported
; EN^XUTMDEVQ 1519 Supported
Q
;
;Main entry point for PRESUMPTIVE PSYCHOSIS PATIENT DETAIL REPORT option
MAIN ; Initial Interactive Processing
N DGSORT,IBOTHSTAT ;array of report parameters
N ZTDESC,ZTQUEUED,ZTREQ,ZTSAVE,ZTSTOP,DGPTNM,DGMTS,VAUTD,%ZIS,SORTENCBY,DGQ
N DGDFN,DFN,VAEL,VADM,VA,I3,DGPID,DGPAGE,DGPPDT,IBOTHSTAT,DGPPWRK,DGPPCAT,DGPPYN
N RECORD ;temp data storage for all records found in file #409.68,and #405 sorted by date of service
N RECORD1 ;temp data storage for all records found in file #409.68,and #405 sorted by division
W @IOF
S DGPPDT=0,SORTENCBY=2
W "PRESUMPTIVE PSYCHOSIS PATIENT DETAIL REPORT",!!
W "This option generates a report of an individual patient treated under"
W !,"Presumptive Psychosis authority within the user specified date range."
W !!,"*** THIS REPORT REQUIRES 132 COLUMN OUTPUT TO PRINT CORRECTLY ***"
W !!,"At the DEVICE: prompt, please accept the default value of '0;132;'"
W !,"This is to deliberately avoid undesired wrapping problems of the data.",!!
;prompt user to enter patient
D PROMPTPT
Q:DGPPYN<1!(+DGSORT<1)
D RECALL^DILFD(2,+DGSORT_",",DUZ)
;Prompt user what type of data/report user wish to see
;user had two options: Eligibility or Encounters
W !
I '$$RPTTYPE Q
;if user selected "ALL", prompt user the DATE FROM and TO for report reconcilliation
I DGSORT("PPRTYPE")="A" D Q:'DGPPDT
. W !!,"Please specify a date range for Episodes of Care and Released Prescription:"
. ;Prompt user for FROM Date of Eligibility Change
. I '$$DATEFROM^DGPPRRPT Q
. ;Prompt user for TO Date of Eligibility Change
. I '$$DATETO^DGPPRRPT Q
. S DGPPDT=1
;
S RECORD=$NA(^TMP($J,"DGPPDDOS"))
S RECORD1=$NA(^TMP($J,"DGPPDDIV"))
S IBOTHSTAT=$NA(^TMP($J,"DGPPIBSTAT"))
K @RECORD ;temp data storage for all records found in file #409.68, #405, #45 sorted by date of service
K @RECORD1 ;temp data storage for all records found in file #409.68, #405, #45 sorted by division
K ^TMP($J,"DGPPDRX52") ;patient's RX information from File #52
K ^TMP($J,"DGALLPPDRX") ;temporary storage for all Rx information and IB status for printing the report
K @IBOTHSTAT ;temp storage for file #350 and file # 399 IB status
W !!
S %ZIS=""
S %ZIS("B")="0;132;"
S ZTSAVE("DGSORT(")=""
S ZTSAVE("DGDFN")=""
S X="PRESUMPTIVE PSYCHOSIS PATIENT DETAIL REPORT"
D EN^XUTMDEVQ("START^DGPPDRPT",X,.ZTSAVE,.%ZIS)
D HOME^%ZIS
Q
;
PROMPTPT ;prompt user to enter patient
S DGPPYN=0
;keep prompting for patient name until user enter patient with PP VA Workaround exist or PP Category
F D Q:DGPPYN
. ;Prompt user for OTH patient name
. S DGPTNM=$$SELPAT(.DGSORT)
. I +DGSORT'>0 S DGPPYN=1 Q
. S (DGDFN,DFN)=DGSORT
. S DGPPWRK=$$PPWRKARN^DGPPAPI(DGDFN) ;check if this patient is registered correctly using PP VA workaround settings
. S DGPPCAT=$$PPINFO^DGPPAPI(DGDFN) ;check for PP category exist
. I $P(DGPPCAT,U)'="Y" S DGPPCAT="N"
. I DGPPWRK="N",($P(DGPPCAT,U)="N") D Q
. . W !!,"WARNING: ** The patient you entered is not a Presumptive Psychosis patient."
. . W !," Please enter another patient.",!!
. S DGPPYN=1
Q
;
SELPAT(DGSORT) ;prompt for veteran's name
;- input vars for ^DIC call
N DIC,DTOUT,DUOUT,X,Y
S DIC="^DPT(",DIC(0)="AEMQZV"
S DIC("A")="Enter Patient Name: "
S DIC("?PARAM",2,"INDEX")="B"
;- lookup patient
D ^DIC K DIC
;- result of lookup
S DGSORT=Y
;- if success, setup return array using output vars from ^DIC call
I (+DGSORT>0) D Q Y(0,0) ;patient name
. S DGSORT=+Y ;patient ien
. S DGSORT(0)=$G(Y(0)) ;zero node of patient in (#2) file
Q -1
;
RPTTYPE() ;prompt for type of data user wish to see
N DGASK,DGDIRA,DGDIRB,DGDIRH,DGDIRO
S DGDIRA="Select the type of report ('E'ligibility/'A'll): "
S DGDIRB=""
S DGDIRH="^D HELP^DGOTHFS2"
S DGDIRO="SAO^E:Eligibility;A:All (Eligibility, Encounter, Prescription)"
S DGASK=$$ANSWER^DGOTHFSM(DGDIRA,DGDIRB,DGDIRO,DGDIRH)
I DGASK="E"!(DGASK="A") S DGSORT("PPRTYPE")=DGASK,DGASK=1
E S DGASK=0
Q DGASK
;
START ;starting point to generate report
I $E(IOST)="C" D WAIT^DICD
N HERE S HERE=$$SITE^VASITE ;extract the IEN and facility name where the report is run
N TRM S TRM=($E(IOST)="C")
N DGENCNT,DGPPFLGRPT,NOREC,DGYN
S (DGQ,DGPAGE,I3,DGENCNT,NOREC,DGYN)=0
S DGPID=$$GET1^DIQ(2,DFN_",",.0905,"I")
S VAUTD=1 ;All the divisions in the facility, since we are not prompting user to enter Division
S DGPPFLGRPT=1 ;this flag will be used to determine which mumps code to execute in DGFSMOUT routine
;only display PP patients with records found in either of the files #409.68, #45, #405, #350, #399, and file #52 record
I DGSORT("PPRTYPE")="A" D
. D GETDATA
. I $O(@RECORD@(""))="" D NOREC
I NOREC,'DGYN D CLEAN W !! D ASKCONT^DGOTHFSM(0) W @IOF Q
;display its eligibility, episodes of care and released prescription if there any
;display the patient's current and verified eligibility
N VA,VADM,VAEL
D 2^VADPT
D CURRENT(DGDFN,DGPTNM)
W !
;display patient's Means Test Status information
D MTS(DGDFN)
;display patient's Rated Disabilities information
D RTDDIS(DGDFN)
Q:DGQ
;display patient's Insurance information
D INS(DGDFN)
Q:DGQ
;if user wants to see patient Encounter and Rx information
I DGSORT("PPRTYPE")="A" D
. I 'NOREC,DGYN Q ;if no record found, we are only displaying the Eligibility portion if user answers Y to the question
. D PPENCTR(DGDFN,.DGSORT) ;display patient's checked out Encounters and inpatient data if there are any
. Q:DGQ
. D PPRX^DGPPDRX(DGDFN,.DGSORT) ;display patient's Released Prescriptions
D CLEAN
Q:DGQ
D ASKCONT^DGOTHFSM(0) W @IOF
Q
;
CLEAN ;clean up data
D KVAR^VADPT
K @RECORD,@RECORD1,@IBOTHSTAT,^TMP($J,"DGPPDRX52"),^TMP($J,"DGALLDPPRX")
D EXIT^DGOTHFSM
Q
;
GETDATA ;Extract records for a patient in files #409.68, #45, #405, #350, #399, and file #52
D CHKTREAT^DGFSMOUT(DGDFN,DGSORT("DGBEG"),DGSORT("DGEND"),.VAUTD,0) ;check if there any past Outpatient Encounter entry (file #409.68) for this patient
D CHECKPTF^DGFSMOUT(DGDFN,DGSORT("DGBEG"),DGSORT("DGEND"),"DGPPIBSTAT") ;check if there any Inpatient stay entry in file #405 and file #45
D CHECKIB^DGFSMOUT("DGPPIBSTAT",DGSORT("DGBEG"),DGSORT("DGEND")) ;check if this patient has records in file #350 or file #399
D CHECKRX^DGFSMOUT("DGPPDRX") ;check at file #52 if this patient has any RX not yet charged
Q
;
NOREC ;diplay verbiage if no recor found
N VA,VADM,VAEL
D 2^VADPT
D PTHDR^DGPPDRP1("PRESUMPTIVE PSYCHOSIS PATIENT DETAIL REPORT")
D LINE^DGPPDRP1(0)
W !!!,">> No Episode of Care and Released Prescription found FROM "_$$FMTE^XLFDT(DGSORT("DGBEG")\1,"5ZF")_" TO "_$$FMTE^XLFDT(DGSORT("DGEND")\1,"5ZF")
W !," You may repeat the query with a different date range."
W !," Or run the Presumptive Psychosis Reconciliation Report option to"
W !," identify Presumptive Psychosis patients with Episode(s) of Care or"
W !," Released Prescription."
W !!
S DGYN=$$YESNO("Do you still want to view the Eligibility section of the report (Y/N)")
I DGYN S NOREC=0 Q
S NOREC=1
D CLEAN
Q
;
YESNO(QUESTION) ;prompt user if still want to display the eligibility portion though no EOC or Rx found
N DIR,Y
S DIR(0)="Y"
S DIR("A")=QUESTION
S DIR("?")=" "
S DIR("?",1)=" Enter 'Y'es if you still want to view the Eligibility of the patient."
S DIR("?",2)=" Otherwise, enter 'N'o"
D ^DIR
Q +Y
;
CURRENT(DFN,PTNAME) ;display patient current and verified PE eligibility
N I1,DGENR,DGENRIEN,DGENRPRI,DGENRGRP
S (DGENRIEN,DGENRPRI,DGENRGRP)=""
D 2^VADPT
D PTHDR^DGPPDRP1("PRESUMPTIVE PSYCHOSIS PATIENT DETAIL REPORT")
D LINE^DGPPDRP1(0)
W !,"Current Eligibility Code : ",$P(VAEL(1),"^",2)," -- ",$S(VAEL(8)']"":"NOT VERIFIED",1:$P(VAEL(8),"^",2))
W " ",$$FMTE^XLFDT($$GET1^DIQ(2,DFN_",",.3612,"I"),"5Z") ;PE eligibility changed date
W !,"Other Eligibility Code(s): " I $D(VAEL(1))>9 S I1=0 F I=0:0 S I=$O(VAEL(1,I)) Q:'I S I1=I1+1 W:I1>1 !?28 W $P(VAEL(1,I),"^",2)
E W "NO ADDITIONAL ELIGIBILITIES IDENTIFIED"
W !,"Presumptive Psychosis : ",$S($P(DGPPCAT,U,3)'="":$P(DGPPCAT,U,3),1:"NONE STATED")
S DGENRIEN=$$FINDCUR^DGENA(DFN)
I DGENRIEN'="" S DGENRPRI=$$GET1^DIQ(27.11,DGENRIEN_",",.07,"E"),DGENRGRP=$$GET1^DIQ(27.11,DGENRIEN_",",.12,"E")
W !,"Enrollment Priority : ",$S(DGENRIEN="":"NOT ENROLLED",((DGENRPRI="")&(DGENRGRP="")):"NONE STATED",1:DGENRPRI_DGENRGRP)
W ! D LINE^DGPPDRP1(1)
Q
;
MTS(DFN) ;display patient's Means Test Status information
S DGMTS=$$MTS^DGMTU(DFN)
I DGMTS="" W !,"Means Test Status : NOT IN MEANS TEST FILE"
E D DIS^DGMTU(DFN)
Q
;
RTDDIS(DFN) ;display patient's rated disabilities information
N DGPTYPE,DGC,DGARR
W !!,"Service Connected : ",$S('+VAEL(3):"NO",1:"YES")
W:+VAEL(3) ?33,"SC Percent : ",$P(VAEL(3),"^",2)_"%"
W !!,"Rated Disabilities: " I 'VAEL(4),$S('$D(^DG(391,+VAEL(6),0)):1,$P(^(0),"^",2):0,1:1) W "NOT A VETERAN" Q
I '$$RDIS^DGRPDB(DFN,.DGARR) W "NONE STATED" Q
F DGC=0:0 S DGC=$O(DGARR(DGC)) Q:'DGC D Q:DGQ
. S I3=I3+1
. N DGP1,DGP2,DGP3,DGZERO
. I $G(DGARR(DGC))']"" Q
. S DGZERO=+DGARR(DGC)
. I '$D(^DIC(31,DGZERO,0)) Q
. S DGP1=$P(^DIC(31,DGZERO,0),U,3)
. S DGP2=$P(^DIC(31,DGZERO,0),U)
. S DGP3="("_$S($P(DGARR(DGC),U,3)=1:$P(DGARR(DGC),U,2)_"% SC",$P(DGARR(DGC),U,3)]"":$P(DGARR(DGC),U,2)_"% NSC",1:"Unspecified")_")"
. I $Y>(IOSL-4) W ! D PAUSE^DGPPDRP1(.DGQ) Q:DGQ D PTHDR^DGPPDRP1,LINE^DGPPDRP1(0)
. W:I3>1 !?20
. W $G(DGP1)_" - ",$E(DGP2,1,30)," ",DGP3
W:'I3 "NONE STATED"
Q
;
INS(DFN) ;display patient's health insurance information
N Z,I,I1
;if patient had more than 6 rated disability, then display the insurance information in a separate page
I I3>6 W !! D PAUSE^DGPPDRP1(.DGQ) Q:DGQ D PTHDR^DGPPDRP1,LINE^DGPPDRP1(0)
W !!,"Health Insurance : "
S Z=$$INSUR^IBBAPI(DFN,DT)
W $S(Z:"YES",1:"NO")
D DISP^DGIBDSP
K I,I1,Z
I $G(DGMTS)="" W !
;break before going back to parent menu
I DGSORT("PPRTYPE")="E" D
. I $Y>(IOSL-4) W ! D PAUSE^DGPPDRP1(.DGQ) Q:DGQ D PTHDR^DGPPDRP1,LINE^DGPPDRP1(0)
. W !!,"<< end of report >>"
Q
;
PPENCTR(DFN,DGSORT) ;display patient's checked out Encounters and inpatient data
N DGTOTENC,PRINTRPT,PPFLG
S DGTOTENC=0
D PAUSE^DGPPDRP1(.DGQ) Q:DGQ D PTHDR^DGPPDRP1,LINE^DGPPDRP1(0)
D ENCHDR^DGPPDRP1(0),ENCTRCOL^DGPPDRP1,LINE^DGPPDRP1(1)
I $O(@RECORD@(""))="" D NOREC
E D
. S $P(DGSORT("SORTENCBY"),U)=1,PRINTRPT=0,PPFLG=1
. D EOC ;remove any RX record and extract the IB status for the oupatient and inpatient record(s)
. S PRINTRPT=1 D EOC ;display PP episode of care
Q
;
EOC ;remove any RX record and extract the IB status for the oupatient and inpatient record(s)
N DGPPDOS,DGPPDIV,FILENO,RECNT,RESULT,STATCNTR,ACTYP,OLDIEN,ENCDT,STATNUM,CHRGCNT,TMPDATA
N NWBILL,OLDBILL,OLDOEDT,SUB1,SUB2,PRNTSEC,DFN405,DFN409,IBFILENO,OUTPATARY
S OLDIEN=""
S (CHRGCNT,PRNTSEC)=0
I PRINTRPT S (OLDBILL,OLDOEDT)=""
S DGPPDOS="" F S DGPPDOS=$O(@RECORD@(DGPPDOS)) Q:DGPPDOS="" D Q:DGQ
. S DGPPDIV="" F S DGPPDIV=$O(@RECORD@(DGPPDOS,DGPPDIV)) Q:DGPPDIV="" D Q:DGQ
. . S FILENO="" F S FILENO=$O(@RECORD@(DGPPDOS,DGPPDIV,FILENO)) Q:FILENO="" D Q:DGQ
. . . S RECNT="" F S RECNT=$O(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT)) Q:RECNT="" D Q:DGQ
. . . . S CHRGCNT=0,(ACTYP,ENCDT,STATNUM)=""
. . . . S SUB1=DGPPDOS,SUB2=DGPPDIV
. . . . I FILENO=350 S ACTYP=$P(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT),U,7)
. . . . I FILENO=399 S ACTYP=$P(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT),U,12)
. . . . I ACTYP["RX"!(ACTYP["PRESCRIPTION")!(FILENO=52) K @RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT) Q ;remove any RX record
. . . . S ENCDT=DGPPDOS,STATNUM=DGPPDIV
. . . . I 'PRINTRPT,(FILENO=409.68!(FILENO=405)) D
. . . . . F IBFILENO=350,399 D
. . . . . . S (DFN405,DFN409)=0
. . . . . . I FILENO=409.68!(FILENO=405) S (DFN405,DFN409)=$P(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT),U,7) ;file #409.68 IEN
. . . . . . I FILENO=405,$P(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT),U,8)'="" S DFN405=$P($P(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT),U,8),";") ;file #405 IEN for file #350 evaluation
. . . . . . I IBFILENO=399 S DFN405=$P($P(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT),U,8),";",2) ;File #45 IEN for file #399 record evaluation
. . . . . . D IBSTATUS^DGFSMOUT(IBFILENO,ENCDT)
. . . . I PRINTRPT>0 D
. . . . . S TMPDATA=@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT)
. . . . . S NWBILL=$S(FILENO=350:$P($P(TMPDATA,U,10),"-",2),FILENO=399:$P(TMPDATA,U,11),1:0)
. . . . . D PRNTENC^DGPPDRP1(TMPDATA,ENCDT) K TMPDATA S OLDBILL=NWBILL,OLDOEDT=ENCDT\1
. . . . Q:DGQ
. . . Q:DGQ
. . Q:DGQ
. Q:DGQ
I PRINTRPT D
. I $O(@RECORD@(""))="" D NOREC1 Q
. Q:DGQ
. W ! D LINE^DGPPDRP1(1)
. W !!,"Total Number of Episode(s) of Care: ",DGTOTENC
K OUTPATARY
Q
;
NOREC1 ;display no record verbiage back to the screen of the user
W !!,">> No Episode of Care found for the date range "_$$FMTE^XLFDT(DGSORT("DGBEG"),"5ZF")_" TO "_$$FMTE^XLFDT(DGSORT("DGEND"),"5ZF")_"."
W !," You may repeat the query with a different date range.",!
W ! D LINE^DGPPDRP1(1)
Q:DGQ
W !!,"Total Number of Episode(s) of Care: ",DGTOTENC
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPPDRPT 15102 printed Sep 23, 2025@20:26:42 Page 2
DGPPDRPT ;SLC/RM - PRESUMPTIVE PSYCHOSIS RECONCILIATION REPORT ; Dec 21, 2020@10:00 am
+1 ;;5.3;Registration;**1035**;Aug 13, 1993;Build 14
+2 ;
+3 ;Global References Supported by ICR# Type
+4 ;----------------- ----------------- -----------
+5 ; ^DG(391 2966 (DG is the Custodial Package) Cont. Sub.
+6 ; ^DIC(31 733 Cont. Sub.
+7 ; ^TMP($J SACC 2.3.2.5.1
+8 ;
+9 ;External References
+10 ;-------------------
+11 ; HOME^%ZIS 10086 Supported
+12 ; $$FINDCUR^DGENA 3812 (DG is the Custodial Package) Cont. Sub.
+13 ; DISP^DGIBDSP 4408 (DG is the Custodial Package) Cont. Sub.
+14 ; $$MTS^DGMTU 642 (DG is the Custodial Package) Cont. Sub.
+15 ; DIS^DGMTU 3789 (DG is the Custodial Package) Cont. Sub.
+16 ; $$RDIS^DGRPDB 4807 Supported
+17 ; ^DIC 10006 Supported
+18 ; WAIT^DICD 10024 Supported
+19 ; RECALL^DILFD 2055 Supported
+20 ; $$GET1^DIQ 2056 Supported
+21 ; $$GET1^DIQ(27.11 4947 (DG is the Custodial Package) Private
+22 ; ^DIR 10026 Supported
+23 ; $$INSUR^IBBAPI 4419 Supported
+24 ; 2^VADPT 10061 Supported
+25 ; KVAR^VADPT 10061 Supported
+26 ; $$SITE^VASITE 10112 Supported
+27 ; $$FMTE^XLFDT 10103 Supported
+28 ; EN^XUTMDEVQ 1519 Supported
+29 QUIT
+30 ;
+31 ;Main entry point for PRESUMPTIVE PSYCHOSIS PATIENT DETAIL REPORT option
MAIN ; Initial Interactive Processing
+1 ;array of report parameters
NEW DGSORT,IBOTHSTAT
+2 NEW ZTDESC,ZTQUEUED,ZTREQ,ZTSAVE,ZTSTOP,DGPTNM,DGMTS,VAUTD,%ZIS,SORTENCBY,DGQ
+3 NEW DGDFN,DFN,VAEL,VADM,VA,I3,DGPID,DGPAGE,DGPPDT,IBOTHSTAT,DGPPWRK,DGPPCAT,DGPPYN
+4 ;temp data storage for all records found in file #409.68,and #405 sorted by date of service
NEW RECORD
+5 ;temp data storage for all records found in file #409.68,and #405 sorted by division
NEW RECORD1
+6 WRITE @IOF
+7 SET DGPPDT=0
SET SORTENCBY=2
+8 WRITE "PRESUMPTIVE PSYCHOSIS PATIENT DETAIL REPORT",!!
+9 WRITE "This option generates a report of an individual patient treated under"
+10 WRITE !,"Presumptive Psychosis authority within the user specified date range."
+11 WRITE !!,"*** THIS REPORT REQUIRES 132 COLUMN OUTPUT TO PRINT CORRECTLY ***"
+12 WRITE !!,"At the DEVICE: prompt, please accept the default value of '0;132;'"
+13 WRITE !,"This is to deliberately avoid undesired wrapping problems of the data.",!!
+14 ;prompt user to enter patient
+15 DO PROMPTPT
+16 if DGPPYN<1!(+DGSORT<1)
QUIT
+17 DO RECALL^DILFD(2,+DGSORT_",",DUZ)
+18 ;Prompt user what type of data/report user wish to see
+19 ;user had two options: Eligibility or Encounters
+20 WRITE !
+21 IF '$$RPTTYPE
QUIT
+22 ;if user selected "ALL", prompt user the DATE FROM and TO for report reconcilliation
+23 IF DGSORT("PPRTYPE")="A"
Begin DoDot:1
+24 WRITE !!,"Please specify a date range for Episodes of Care and Released Prescription:"
+25 ;Prompt user for FROM Date of Eligibility Change
+26 IF '$$DATEFROM^DGPPRRPT
QUIT
+27 ;Prompt user for TO Date of Eligibility Change
+28 IF '$$DATETO^DGPPRRPT
QUIT
+29 SET DGPPDT=1
End DoDot:1
if 'DGPPDT
QUIT
+30 ;
+31 SET RECORD=$NAME(^TMP($JOB,"DGPPDDOS"))
+32 SET RECORD1=$NAME(^TMP($JOB,"DGPPDDIV"))
+33 SET IBOTHSTAT=$NAME(^TMP($JOB,"DGPPIBSTAT"))
+34 ;temp data storage for all records found in file #409.68, #405, #45 sorted by date of service
KILL @RECORD
+35 ;temp data storage for all records found in file #409.68, #405, #45 sorted by division
KILL @RECORD1
+36 ;patient's RX information from File #52
KILL ^TMP($JOB,"DGPPDRX52")
+37 ;temporary storage for all Rx information and IB status for printing the report
KILL ^TMP($JOB,"DGALLPPDRX")
+38 ;temp storage for file #350 and file # 399 IB status
KILL @IBOTHSTAT
+39 WRITE !!
+40 SET %ZIS=""
+41 SET %ZIS("B")="0;132;"
+42 SET ZTSAVE("DGSORT(")=""
+43 SET ZTSAVE("DGDFN")=""
+44 SET X="PRESUMPTIVE PSYCHOSIS PATIENT DETAIL REPORT"
+45 DO EN^XUTMDEVQ("START^DGPPDRPT",X,.ZTSAVE,.%ZIS)
+46 DO HOME^%ZIS
+47 QUIT
+48 ;
PROMPTPT ;prompt user to enter patient
+1 SET DGPPYN=0
+2 ;keep prompting for patient name until user enter patient with PP VA Workaround exist or PP Category
+3 FOR
Begin DoDot:1
+4 ;Prompt user for OTH patient name
+5 SET DGPTNM=$$SELPAT(.DGSORT)
+6 IF +DGSORT'>0
SET DGPPYN=1
QUIT
+7 SET (DGDFN,DFN)=DGSORT
+8 ;check if this patient is registered correctly using PP VA workaround settings
SET DGPPWRK=$$PPWRKARN^DGPPAPI(DGDFN)
+9 ;check for PP category exist
SET DGPPCAT=$$PPINFO^DGPPAPI(DGDFN)
+10 IF $PIECE(DGPPCAT,U)'="Y"
SET DGPPCAT="N"
+11 IF DGPPWRK="N"
IF ($PIECE(DGPPCAT,U)="N")
Begin DoDot:2
+12 WRITE !!,"WARNING: ** The patient you entered is not a Presumptive Psychosis patient."
+13 WRITE !," Please enter another patient.",!!
End DoDot:2
QUIT
+14 SET DGPPYN=1
End DoDot:1
if DGPPYN
QUIT
+15 QUIT
+16 ;
SELPAT(DGSORT) ;prompt for veteran's name
+1 ;- input vars for ^DIC call
+2 NEW DIC,DTOUT,DUOUT,X,Y
+3 SET DIC="^DPT("
SET DIC(0)="AEMQZV"
+4 SET DIC("A")="Enter Patient Name: "
+5 SET DIC("?PARAM",2,"INDEX")="B"
+6 ;- lookup patient
+7 DO ^DIC
KILL DIC
+8 ;- result of lookup
+9 SET DGSORT=Y
+10 ;- if success, setup return array using output vars from ^DIC call
+11 ;patient name
IF (+DGSORT>0)
Begin DoDot:1
+12 ;patient ien
SET DGSORT=+Y
+13 ;zero node of patient in (#2) file
SET DGSORT(0)=$GET(Y(0))
End DoDot:1
QUIT Y(0,0)
+14 QUIT -1
+15 ;
RPTTYPE() ;prompt for type of data user wish to see
+1 NEW DGASK,DGDIRA,DGDIRB,DGDIRH,DGDIRO
+2 SET DGDIRA="Select the type of report ('E'ligibility/'A'll): "
+3 SET DGDIRB=""
+4 SET DGDIRH="^D HELP^DGOTHFS2"
+5 SET DGDIRO="SAO^E:Eligibility;A:All (Eligibility, Encounter, Prescription)"
+6 SET DGASK=$$ANSWER^DGOTHFSM(DGDIRA,DGDIRB,DGDIRO,DGDIRH)
+7 IF DGASK="E"!(DGASK="A")
SET DGSORT("PPRTYPE")=DGASK
SET DGASK=1
+8 IF '$TEST
SET DGASK=0
+9 QUIT DGASK
+10 ;
START ;starting point to generate report
+1 IF $EXTRACT(IOST)="C"
DO WAIT^DICD
+2 ;extract the IEN and facility name where the report is run
NEW HERE
SET HERE=$$SITE^VASITE
+3 NEW TRM
SET TRM=($EXTRACT(IOST)="C")
+4 NEW DGENCNT,DGPPFLGRPT,NOREC,DGYN
+5 SET (DGQ,DGPAGE,I3,DGENCNT,NOREC,DGYN)=0
+6 SET DGPID=$$GET1^DIQ(2,DFN_",",.0905,"I")
+7 ;All the divisions in the facility, since we are not prompting user to enter Division
SET VAUTD=1
+8 ;this flag will be used to determine which mumps code to execute in DGFSMOUT routine
SET DGPPFLGRPT=1
+9 ;only display PP patients with records found in either of the files #409.68, #45, #405, #350, #399, and file #52 record
+10 IF DGSORT("PPRTYPE")="A"
Begin DoDot:1
+11 DO GETDATA
+12 IF $ORDER(@RECORD@(""))=""
DO NOREC
End DoDot:1
+13 IF NOREC
IF 'DGYN
DO CLEAN
WRITE !!
DO ASKCONT^DGOTHFSM(0)
WRITE @IOF
QUIT
+14 ;display its eligibility, episodes of care and released prescription if there any
+15 ;display the patient's current and verified eligibility
+16 NEW VA,VADM,VAEL
+17 DO 2^VADPT
+18 DO CURRENT(DGDFN,DGPTNM)
+19 WRITE !
+20 ;display patient's Means Test Status information
+21 DO MTS(DGDFN)
+22 ;display patient's Rated Disabilities information
+23 DO RTDDIS(DGDFN)
+24 if DGQ
QUIT
+25 ;display patient's Insurance information
+26 DO INS(DGDFN)
+27 if DGQ
QUIT
+28 ;if user wants to see patient Encounter and Rx information
+29 IF DGSORT("PPRTYPE")="A"
Begin DoDot:1
+30 ;if no record found, we are only displaying the Eligibility portion if user answers Y to the question
IF 'NOREC
IF DGYN
QUIT
+31 ;display patient's checked out Encounters and inpatient data if there are any
DO PPENCTR(DGDFN,.DGSORT)
+32 if DGQ
QUIT
+33 ;display patient's Released Prescriptions
DO PPRX^DGPPDRX(DGDFN,.DGSORT)
End DoDot:1
+34 DO CLEAN
+35 if DGQ
QUIT
+36 DO ASKCONT^DGOTHFSM(0)
WRITE @IOF
+37 QUIT
+38 ;
CLEAN ;clean up data
+1 DO KVAR^VADPT
+2 KILL @RECORD,@RECORD1,@IBOTHSTAT,^TMP($JOB,"DGPPDRX52"),^TMP($JOB,"DGALLDPPRX")
+3 DO EXIT^DGOTHFSM
+4 QUIT
+5 ;
GETDATA ;Extract records for a patient in files #409.68, #45, #405, #350, #399, and file #52
+1 ;check if there any past Outpatient Encounter entry (file #409.68) for this patient
DO CHKTREAT^DGFSMOUT(DGDFN,DGSORT("DGBEG"),DGSORT("DGEND"),.VAUTD,0)
+2 ;check if there any Inpatient stay entry in file #405 and file #45
DO CHECKPTF^DGFSMOUT(DGDFN,DGSORT("DGBEG"),DGSORT("DGEND"),"DGPPIBSTAT")
+3 ;check if this patient has records in file #350 or file #399
DO CHECKIB^DGFSMOUT("DGPPIBSTAT",DGSORT("DGBEG"),DGSORT("DGEND"))
+4 ;check at file #52 if this patient has any RX not yet charged
DO CHECKRX^DGFSMOUT("DGPPDRX")
+5 QUIT
+6 ;
NOREC ;diplay verbiage if no recor found
+1 NEW VA,VADM,VAEL
+2 DO 2^VADPT
+3 DO PTHDR^DGPPDRP1("PRESUMPTIVE PSYCHOSIS PATIENT DETAIL REPORT")
+4 DO LINE^DGPPDRP1(0)
+5 WRITE !!!,">> No Episode of Care and Released Prescription found FROM "_$$FMTE^XLFDT(DGSORT("DGBEG")\1,"5ZF")_" TO "_$$FMTE^XLFDT(DGSORT("DGEND")\1,"5ZF")
+6 WRITE !," You may repeat the query with a different date range."
+7 WRITE !," Or run the Presumptive Psychosis Reconciliation Report option to"
+8 WRITE !," identify Presumptive Psychosis patients with Episode(s) of Care or"
+9 WRITE !," Released Prescription."
+10 WRITE !!
+11 SET DGYN=$$YESNO("Do you still want to view the Eligibility section of the report (Y/N)")
+12 IF DGYN
SET NOREC=0
QUIT
+13 SET NOREC=1
+14 DO CLEAN
+15 QUIT
+16 ;
YESNO(QUESTION) ;prompt user if still want to display the eligibility portion though no EOC or Rx found
+1 NEW DIR,Y
+2 SET DIR(0)="Y"
+3 SET DIR("A")=QUESTION
+4 SET DIR("?")=" "
+5 SET DIR("?",1)=" Enter 'Y'es if you still want to view the Eligibility of the patient."
+6 SET DIR("?",2)=" Otherwise, enter 'N'o"
+7 DO ^DIR
+8 QUIT +Y
+9 ;
CURRENT(DFN,PTNAME) ;display patient current and verified PE eligibility
+1 NEW I1,DGENR,DGENRIEN,DGENRPRI,DGENRGRP
+2 SET (DGENRIEN,DGENRPRI,DGENRGRP)=""
+3 DO 2^VADPT
+4 DO PTHDR^DGPPDRP1("PRESUMPTIVE PSYCHOSIS PATIENT DETAIL REPORT")
+5 DO LINE^DGPPDRP1(0)
+6 WRITE !,"Current Eligibility Code : ",$PIECE(VAEL(1),"^",2)," -- ",$SELECT(VAEL(8)']"":"NOT VERIFIED",1:$PIECE(VAEL(8),"^",2))
+7 ;PE eligibility changed date
WRITE " ",$$FMTE^XLFDT($$GET1^DIQ(2,DFN_",",.3612,"I"),"5Z")
+8 WRITE !,"Other Eligibility Code(s): "
IF $DATA(VAEL(1))>9
SET I1=0
FOR I=0:0
SET I=$ORDER(VAEL(1,I))
if 'I
QUIT
SET I1=I1+1
if I1>1
WRITE !?28
WRITE $PIECE(VAEL(1,I),"^",2)
+9 IF '$TEST
WRITE "NO ADDITIONAL ELIGIBILITIES IDENTIFIED"
+10 WRITE !,"Presumptive Psychosis : ",$SELECT($PIECE(DGPPCAT,U,3)'="":$PIECE(DGPPCAT,U,3),1:"NONE STATED")
+11 SET DGENRIEN=$$FINDCUR^DGENA(DFN)
+12 IF DGENRIEN'=""
SET DGENRPRI=$$GET1^DIQ(27.11,DGENRIEN_",",.07,"E")
SET DGENRGRP=$$GET1^DIQ(27.11,DGENRIEN_",",.12,"E")
+13 WRITE !,"Enrollment Priority : ",$SELECT(DGENRIEN="":"NOT ENROLLED",((DGENRPRI="")&(DGENRGRP="")):"NONE STATED",1:DGENRPRI_DGENRGRP)
+14 WRITE !
DO LINE^DGPPDRP1(1)
+15 QUIT
+16 ;
MTS(DFN) ;display patient's Means Test Status information
+1 SET DGMTS=$$MTS^DGMTU(DFN)
+2 IF DGMTS=""
WRITE !,"Means Test Status : NOT IN MEANS TEST FILE"
+3 IF '$TEST
DO DIS^DGMTU(DFN)
+4 QUIT
+5 ;
RTDDIS(DFN) ;display patient's rated disabilities information
+1 NEW DGPTYPE,DGC,DGARR
+2 WRITE !!,"Service Connected : ",$SELECT('+VAEL(3):"NO",1:"YES")
+3 if +VAEL(3)
WRITE ?33,"SC Percent : ",$PIECE(VAEL(3),"^",2)_"%"
+4 WRITE !!,"Rated Disabilities: "
IF 'VAEL(4)
IF $SELECT('$DATA(^DG(391,+VAEL(6),0)):1,$PIECE(^(0),"^",2):0,1:1)
WRITE "NOT A VETERAN"
QUIT
+5 IF '$$RDIS^DGRPDB(DFN,.DGARR)
WRITE "NONE STATED"
QUIT
+6 FOR DGC=0:0
SET DGC=$ORDER(DGARR(DGC))
if 'DGC
QUIT
Begin DoDot:1
+7 SET I3=I3+1
+8 NEW DGP1,DGP2,DGP3,DGZERO
+9 IF $GET(DGARR(DGC))']""
QUIT
+10 SET DGZERO=+DGARR(DGC)
+11 IF '$DATA(^DIC(31,DGZERO,0))
QUIT
+12 SET DGP1=$PIECE(^DIC(31,DGZERO,0),U,3)
+13 SET DGP2=$PIECE(^DIC(31,DGZERO,0),U)
+14 SET DGP3="("_$SELECT($PIECE(DGARR(DGC),U,3)=1:$PIECE(DGARR(DGC),U,2)_"% SC",$PIECE(DGARR(DGC),U,3)]"":$PIECE(DGARR(DGC),U,2)_"% NSC",1:"Unspecified")_")"
+15 IF $Y>(IOSL-4)
WRITE !
DO PAUSE^DGPPDRP1(.DGQ)
if DGQ
QUIT
DO PTHDR^DGPPDRP1
DO LINE^DGPPDRP1(0)
+16 if I3>1
WRITE !?20
+17 WRITE $GET(DGP1)_" - ",$EXTRACT(DGP2,1,30)," ",DGP3
End DoDot:1
if DGQ
QUIT
+18 if 'I3
WRITE "NONE STATED"
+19 QUIT
+20 ;
INS(DFN) ;display patient's health insurance information
+1 NEW Z,I,I1
+2 ;if patient had more than 6 rated disability, then display the insurance information in a separate page
+3 IF I3>6
WRITE !!
DO PAUSE^DGPPDRP1(.DGQ)
if DGQ
QUIT
DO PTHDR^DGPPDRP1
DO LINE^DGPPDRP1(0)
+4 WRITE !!,"Health Insurance : "
+5 SET Z=$$INSUR^IBBAPI(DFN,DT)
+6 WRITE $SELECT(Z:"YES",1:"NO")
+7 DO DISP^DGIBDSP
+8 KILL I,I1,Z
+9 IF $GET(DGMTS)=""
WRITE !
+10 ;break before going back to parent menu
+11 IF DGSORT("PPRTYPE")="E"
Begin DoDot:1
+12 IF $Y>(IOSL-4)
WRITE !
DO PAUSE^DGPPDRP1(.DGQ)
if DGQ
QUIT
DO PTHDR^DGPPDRP1
DO LINE^DGPPDRP1(0)
+13 WRITE !!,"<< end of report >>"
End DoDot:1
+14 QUIT
+15 ;
PPENCTR(DFN,DGSORT) ;display patient's checked out Encounters and inpatient data
+1 NEW DGTOTENC,PRINTRPT,PPFLG
+2 SET DGTOTENC=0
+3 DO PAUSE^DGPPDRP1(.DGQ)
if DGQ
QUIT
DO PTHDR^DGPPDRP1
DO LINE^DGPPDRP1(0)
+4 DO ENCHDR^DGPPDRP1(0)
DO ENCTRCOL^DGPPDRP1
DO LINE^DGPPDRP1(1)
+5 IF $ORDER(@RECORD@(""))=""
DO NOREC
+6 IF '$TEST
Begin DoDot:1
+7 SET $PIECE(DGSORT("SORTENCBY"),U)=1
SET PRINTRPT=0
SET PPFLG=1
+8 ;remove any RX record and extract the IB status for the oupatient and inpatient record(s)
DO EOC
+9 ;display PP episode of care
SET PRINTRPT=1
DO EOC
End DoDot:1
+10 QUIT
+11 ;
EOC ;remove any RX record and extract the IB status for the oupatient and inpatient record(s)
+1 NEW DGPPDOS,DGPPDIV,FILENO,RECNT,RESULT,STATCNTR,ACTYP,OLDIEN,ENCDT,STATNUM,CHRGCNT,TMPDATA
+2 NEW NWBILL,OLDBILL,OLDOEDT,SUB1,SUB2,PRNTSEC,DFN405,DFN409,IBFILENO,OUTPATARY
+3 SET OLDIEN=""
+4 SET (CHRGCNT,PRNTSEC)=0
+5 IF PRINTRPT
SET (OLDBILL,OLDOEDT)=""
+6 SET DGPPDOS=""
FOR
SET DGPPDOS=$ORDER(@RECORD@(DGPPDOS))
if DGPPDOS=""
QUIT
Begin DoDot:1
+7 SET DGPPDIV=""
FOR
SET DGPPDIV=$ORDER(@RECORD@(DGPPDOS,DGPPDIV))
if DGPPDIV=""
QUIT
Begin DoDot:2
+8 SET FILENO=""
FOR
SET FILENO=$ORDER(@RECORD@(DGPPDOS,DGPPDIV,FILENO))
if FILENO=""
QUIT
Begin DoDot:3
+9 SET RECNT=""
FOR
SET RECNT=$ORDER(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT))
if RECNT=""
QUIT
Begin DoDot:4
+10 SET CHRGCNT=0
SET (ACTYP,ENCDT,STATNUM)=""
+11 SET SUB1=DGPPDOS
SET SUB2=DGPPDIV
+12 IF FILENO=350
SET ACTYP=$PIECE(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT),U,7)
+13 IF FILENO=399
SET ACTYP=$PIECE(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT),U,12)
+14 ;remove any RX record
IF ACTYP["RX"!(ACTYP["PRESCRIPTION")!(FILENO=52)
KILL @RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT)
QUIT
+15 SET ENCDT=DGPPDOS
SET STATNUM=DGPPDIV
+16 IF 'PRINTRPT
IF (FILENO=409.68!(FILENO=405))
Begin DoDot:5
+17 FOR IBFILENO=350,399
Begin DoDot:6
+18 SET (DFN405,DFN409)=0
+19 ;file #409.68 IEN
IF FILENO=409.68!(FILENO=405)
SET (DFN405,DFN409)=$PIECE(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT),U,7)
+20 ;file #405 IEN for file #350 evaluation
IF FILENO=405
IF $PIECE(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT),U,8)'=""
SET DFN405=$PIECE($PIECE(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT),U,8),";")
+21 ;File #45 IEN for file #399 record evaluation
IF IBFILENO=399
SET DFN405=$PIECE($PIECE(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT),U,8),";",2)
+22 DO IBSTATUS^DGFSMOUT(IBFILENO,ENCDT)
End DoDot:6
End DoDot:5
+23 IF PRINTRPT>0
Begin DoDot:5
+24 SET TMPDATA=@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT)
+25 SET NWBILL=$SELECT(FILENO=350:$PIECE($PIECE(TMPDATA,U,10),"-",2),FILENO=399:$PIECE(TMPDATA,U,11),1:0)
+26 DO PRNTENC^DGPPDRP1(TMPDATA,ENCDT)
KILL TMPDATA
SET OLDBILL=NWBILL
SET OLDOEDT=ENCDT\1
End DoDot:5
+27 if DGQ
QUIT
End DoDot:4
if DGQ
QUIT
+28 if DGQ
QUIT
End DoDot:3
if DGQ
QUIT
+29 if DGQ
QUIT
End DoDot:2
if DGQ
QUIT
+30 if DGQ
QUIT
End DoDot:1
if DGQ
QUIT
+31 IF PRINTRPT
Begin DoDot:1
+32 IF $ORDER(@RECORD@(""))=""
DO NOREC1
QUIT
+33 if DGQ
QUIT
+34 WRITE !
DO LINE^DGPPDRP1(1)
+35 WRITE !!,"Total Number of Episode(s) of Care: ",DGTOTENC
End DoDot:1
+36 KILL OUTPATARY
+37 QUIT
+38 ;
NOREC1 ;display no record verbiage back to the screen of the user
+1 WRITE !!,">> No Episode of Care found for the date range "_$$FMTE^XLFDT(DGSORT("DGBEG"),"5ZF")_" TO "_$$FMTE^XLFDT(DGSORT("DGEND"),"5ZF")_"."
+2 WRITE !," You may repeat the query with a different date range.",!
+3 WRITE !
DO LINE^DGPPDRP1(1)
+4 if DGQ
QUIT
+5 WRITE !!,"Total Number of Episode(s) of Care: ",DGTOTENC
+6 QUIT
+7 ;
