- 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 Feb 19, 2025@00:16:51 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 ;