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

DGPPDRPT.m

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