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

DGPOTEN.m

Go to the documentation of this file. 
  1. DGPOTEN ;SLC/RM/JC - POTENTIAL PRESUMPTIVE PSYCHOSIS REPORT ; Apr 1, 2021@12:54:25 pm
  1.  ;;5.3;Registration;**1047**;Aug 13, 1993;Build 13
  1.  ;
  1.  Q
  1.  ;
  1.  ;Main entry point for PRESUMPTIVE PSYCHOSIS POTENTIAL REPORT option
  1. MAIN ;
  1.  N DGSORT   ;array of report parameters
  1.  N ZTDESC,ZTQUEUED,ZTREQ,ZTSAVE,ZTSTOP
  1.  W @IOF
  1.  W "POTENTIAL PRESUMPTIVE PSYCHOSIS REPORT"
  1.  W !!,"This option generates a list of patients who have been registered in"
  1.  W !,"VistA using the Presumptive Psychosis 'workaround' since 38 U.S. Code"
  1.  W !,"1702 was passed on 3/14/2013."
  1.  W !!,"Registration/Eligibility staff can use this list to view patient"
  1.  W !,"registrations to assign the Presumptive Psychosis Indicator found in"
  1.  W !,"VistA screen 7, if applicable."
  1.  W !!,"The default start date is the date the United State Code was put into"
  1.  W !,"effect; however, you can select a later start date.",!
  1.  W !,"You can also select a different end date for the report.  Default is TODAY.",!
  1.  ;Prompt user for FROM Date of Eligibility Change
  1.  I '$$DATEFROM Q
  1.  ;Prompt user for TO Date of Eligibility Change
  1.  I '$$DATETO Q
  1.  ;prompt for device
  1.  W !
  1.  S ZTSAVE("DGSORT(")=""
  1.  S X="POTENTIAL PRESUMPTIVE PSYCHOSIS PATIENT REPORT"
  1.  D EN^XUTMDEVQ("START^DGPOTEN",X,.ZTSAVE)  ;JMC
  1.  D HOME^%ZIS
  1.  Q
  1.  ;
  1. START ; compile and print 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 DGPOTENLST ;temp data storage used for PP Potential report list
  1.  N RECORD,IBOTHSTAT  ;JMC
  1.  S DGPOTENLST=$NA(^TMP($J,"DGPPPOTEN")) ;contains all PP data to be displayed in the report
  1.  S RECORD=$NA(^TMP($J,"DGPOTENREC")) ;contains all PP episodes of care data found in file #409.68,#52,#405,#45,#350,#399
  1.  S IBOTHSTAT=$NA(^TMP($J,"DGPPIBPOTEN")) ;contains file #350,#399  ;JMC
  1.  K @DGPOTENLST,@RECORD,@IBOTHSTAT  ;JMC
  1.  D LOOP(.DGSORT,DGPOTENLST)
  1.  D PRINTPP(.DGSORT,DGPOTENLST)
  1.  K @DGPOTENLST,@RECORD,@IBOTHSTAT  ;JMC
  1.  D EXIT
  1.  Q
  1.  ;
  1. LOOP(DGSORT,DGPOTENLST) ;
  1.  N DGDFN,VAUTD,SORTENCBY,CPT,DGPTNAME,DGPID,DGDOB,DGENCNT,DGPPWRK,DGPPCAT
  1.  N VAEL,VADM,DGDOD,DATA,VA,DFN,I,I1,DGPPFLGRPT,DGPPREGDT,DGLASTEOC
  1.  S SORTENCBY=0
  1.  ;PP VA Workaround
  1.  ; Registration Screen <7>
  1.  ; - Patient Type: SC Veteran
  1.  ; - Veteran : Yes
  1.  ; - Service Connected: Yes
  1.  ; - Service Connected %: 0%
  1.  ; - Primary Elig Code: SC LESS THAN 50%
  1.  ; - Other Elig Code(s): HUMANITARIAN EMERGENCY
  1.  ; Registration Screen <5>
  1.  ; - VHA DIRECTIVE 1029 WNR   (This is a Free text for insurance buffer entry)
  1.  ; Registration Screen <11>
  1.  ; - Select RATED DISABILITIES (VA):  9410
  1.  ; - DISABILITY %: 0
  1.  ; and/or with
  1.  ; Registration Screen <7>
  1.  ; - PP Indicator (SHRPE 1.0)
  1.  ;Please Note:
  1.  ; This report will not filter the facility/division of the episodes of care where the report is run
  1.  ; It will display all facility/division regardless
  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.  ;Loop through all PATIENT file #2
  1.  S (DGDFN,CPT)=0 F  S DGDFN=$O(^DPT(DGDFN)) Q:'DGDFN  D
  1.  . S CPT=CPT+1 W:'(CPT#60000) "." ;write . every 60,000 processed records
  1.  . S DGPPCAT=$$PPINFO^DGPPAPI(DGDFN)
  1.  . Q:$P(DGPPCAT,U)="Y"  ;patients with PP category will not be included into the report
  1.  . S DGPPWRK=$$PPWRKARN^DGPPAPI(DGDFN) ;check if this patient is registered correctly using PP VA workaround settings
  1.  . I $P(DGPPCAT,U)'="Y" S DGPPCAT="N"
  1.  . I DGPPWRK="Y",DGPPCAT="N" D  ;if PP VA Workaround exist, extract episode of care/inpatient/bill charges/rx
  1.  . . K @RECORD ;evaluate each patient one at a time
  1.  . . S (DGENCNT,I1,I)=0
  1.  . . S DGPTNAME=$$GET1^DIQ(2,DGDFN_",",.01,"E")
  1.  . . S DGPID=$$GET1^DIQ(2,DGDFN_",",.0905,"I")
  1.  . . S DGPPREGDT=$$GET1^DIQ(2,DGDFN_",",.097,"I") ;Vista Registration Entry
  1.  . . S DGLASTEOC=$$LASTEOC(DGDFN)
  1.  . . S DGDOD=$$GET1^DIQ(2,DGDFN_",",.351,"I")\1 ;date of death
  1.  . . S DATA=DGPTNAME_U_DGPID_U_DGPPREGDT_U_DGLASTEOC_U_$S(+DGDOD<1:"N/A",1:DGDOD)
  1.  . . I $G(DGLASTEOC)="NO DATA FOUND" Q  ;JMC  Prevents either out of range or no data found from appearing on report.
  1.  . . S @DGPOTENLST@(DGPTNAME,DGDFN)=DATA
  1.  Q
  1.  ;
  1. LASTEOC(DFN) ;extract all Episode of Care and Rx and return the most current Episode of Care for a patient
  1.  N DGLASTEOC
  1.  D CHKTREAT^DGFSMOUT(+DFN,DGSORT("DGBEG"),DGSORT("DGEND"),.VAUTD,0) ;check if there any past Outpatient Encounter entry in file #409.68
  1.  D CHECKPTF^DGFSMOUT(DFN,DGSORT("DGBEG"),DGSORT("DGEND"),"DGPPIBPOTEN") ;check if there any Inpatient stay entry in file #405
  1.  D CHECKIB^DGFSMOUT("DGPPIBPOTEN",DGSORT("DGBEG"),DGSORT("DGEND")) K ^TMP($J,"DGPPIBPOTEN") ;check if this patient has records in file #350 or file #399
  1.  D CHECKRX^DGFSMOUT("DGPPRXPOTEN") ;check at file #52 if this patient has any RX not yet charged
  1.  I $O(@RECORD@(""))="" S DGLASTEOC="NO DATA FOUND"
  1.  E  D PPDATE
  1.  I DGLASTEOC<DGSORT("DGBEG") S DGLASTEOC="NO DATA FOUND"
  1.  I DGLASTEOC>DGSORT("DGEND") S DGLASTEOC="NO DATA FOUND"
  1.  Q DGLASTEOC
  1.  ;
  1. PPDATE ;
  1.  N DGDOS,DGSTATN,FILENO,CNT,PPDTARY
  1.  S DGLASTEOC=0
  1.  S DGDOS="" F  S DGDOS=$O(@RECORD@(DGDOS)) Q:DGDOS=""  D
  1.  . S DGSTATN="" F  S DGSTATN=$O(@RECORD@(DGDOS,DGSTATN)) Q:DGSTATN=""  D
  1.  . . S FILENO="" F  S FILENO=$O(@RECORD@(DGDOS,DGSTATN,FILENO)) Q:FILENO=""  D
  1.  . . . S CNT="" F  S CNT=$O(@RECORD@(DGDOS,DGSTATN,FILENO,CNT)) Q:CNT=""  D
  1.  . . . . I '$D(PPDTARY(DGDOS\1))="" S DGLASTEOC=DGDOS\1
  1.  . . . . E  I DGLASTEOC<DGDOS\1 S DGLASTEOC=DGDOS\1
  1.  Q
  1.  ;
  1. PRINTPP(DGSORT,DGPOTENLST) ;
  1.  N DGPAGE,DDASH,DGQ,DGDFN,DGTOTAL,DGPRINT,DGOLD,DGSTATN,DGPTNAME,DGLSTEOC,DGDOD,DGDTOFREG
  1.  S (DGQ,DGTOTAL,DGPAGE,DGPRINT,DGOLD)=0,$P(DDASH,"=",81)=""
  1.  I $O(@DGPOTENLST@(""))="" D  Q
  1.  . D HEADER,COLHEAD
  1.  . W !!!," >>> No records were found using the report criteria.",!!
  1.  . W ! D LINE
  1.  . D ASKCONT(0)
  1.  ; loop and print report
  1.  D HEADER,COLHEAD
  1.  S DGPTNAME="" F  S DGPTNAME=$O(@DGPOTENLST@(DGPTNAME)) Q:DGPTNAME=""  D  Q:DGQ
  1.  . S DGDFN="" F  S DGDFN=$O(@DGPOTENLST@(DGPTNAME,DGDFN)) Q:DGDFN=""  D  Q:DGQ
  1.  . . I $Y>(IOSL-4) W ! D PAUSE(.DGQ) Q:DGQ  D HEADER,COLHEAD
  1.  . . S DGDTOFREG=$P(@DGPOTENLST@(DGPTNAME,DGDFN),U,3)
  1.  . . W $E(DGPTNAME,1,30),?32,$P(@DGPOTENLST@(DGPTNAME,DGDFN),U,2),?39,$S(DGDTOFREG'="":$$FMTE^XLFDT(DGDTOFREG,"5Z"),1:"NONE ENTERED")
  1.  . . S DGLSTEOC=$P(@DGPOTENLST@(DGPTNAME,DGDFN),U,4)
  1.  . . I DGLSTEOC'?.N W ?53,DGLSTEOC
  1.  . . E  W ?53,$$FMTE^XLFDT(DGLSTEOC,"5Z")
  1.  . . S DGDOD=$P(@DGPOTENLST@(DGPTNAME,DGDFN),U,5)
  1.  . . I DGDOD'?.N W ?69,DGDOD
  1.  . . E  W ?69,$$FMTE^XLFDT(DGDOD\1,"5Z")
  1.  . . W !
  1.  . . S DGTOTAL=DGTOTAL+1
  1.  . Q:DGQ
  1.  Q:DGQ
  1.  D LINE
  1.  W !!,"Number of Unique Patients:  ",$J(DGTOTAL,5)
  1.  W !!,"<< end of report >>"
  1.  D ASKCONT(0) W @IOF
  1.  Q
  1.  ;
  1.  ;
  1.  N DGFACLTY,DGDTRNGE,DTPRNTD
  1.  I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,DGQ)=1 Q
  1.  I TRM!('TRM&DGPAGE) W @IOF
  1.  S DGPAGE=$G(DGPAGE)+1
  1.  W "REPORT RUN DATE: ",$$FMTE^XLFDT($$NOW^XLFDT,"MP")
  1.  W ?44,"DATE RANGE: ",$$FMTE^XLFDT(DGSORT("DGBEG"),"5Z")," TO ",$$FMTE^XLFDT(DGSORT("DGEND"),"5Z")
  1.  W ! D LINE W !
  1.  W ?(80-$L(ZTDESC))\2,$G(ZTDESC),?70,"Page: ",DGPAGE
  1.  S DGFACLTY="FACILITY: "_$P(HERE,U,2)
  1.  W !,?(80-$L(DGFACLTY))\2,DGFACLTY
  1.  W ! D LINE W !
  1.  Q
  1.  ;
  1. LINE     ;prints double dash line
  1.  N LINE
  1.  F LINE=1:1:80 W "="
  1.  Q
  1.  ;
  1. COLHEAD  ;report column header
  1.  W "PATIENT NAME",?32,"PID",?39,"REGISTRATION",?53,"LAST EPISODE",?69,"DATE OF"
  1.  W !,?39,"DATE",?53,"OF CARE",?69,"DEATH"
  1.  W ! D LINE W !
  1.  Q
  1.  ;
  1. ASKCONT(FLAG) ; display "press <Enter> to continue" prompt
  1.  N Z
  1.  W !!,$$CJ^XLFSTR("Press <Enter> to "_$S(FLAG=1:"continue.",1:"exit."),20)
  1.  R !,Z:DTIME
  1.  Q
  1.  ;
  1. PAUSE(DGQ) ; pause screen display
  1.  ; Input: 
  1.  ; DGQ - var used to quit report processing to user CRT
  1.  ; Output:
  1.  ; DGQ - passed by reference - 0 = Continue, 1 = Quit
  1.  ;
  1.  I $G(DGPAGE)>0,TRM K DIR S DIR(0)="E" D ^DIR K DIR S:+Y=0 DGQ=1
  1.  Q
  1.  ;
  1. EXIT ;
  1.  Q
  1.  ;
  1. DATEFROM() ;prompt for FROM Date of Service
  1.  N DGASK,DGDIRA,DGDIRB,DGDIRH,DGDIRO,DGBEGDT,DGSTRTDT
  1.  S DGBEGDT=3130314 ;03/14/2013 - Presumptive Psychosis legislation date
  1.  S DGDIRA=" Start with Date:  "
  1.  S DGDIRB=$$FMTE^XLFDT(DGBEGDT)
  1.  S DGDIRH="^D HELP^DGPPRRPT(1)"
  1.  S DGDIRO="DA^"_DGBEGDT_":DT:EX"
  1.  S DGASK=$$ANSWER(DGDIRA,DGDIRB,DGDIRO,DGDIRH)
  1.  I DGASK>0 S DGSORT("DGBEG")=$S(DGASK<DGBEGDT:DGBEGDT,1:DGASK)
  1.  Q DGASK>0
  1.  ;
  1. DATETO() ;prompt for TO Date of Service
  1.  N DGASK,DGDIRA,DGDIRB,DGDIRH,DGDIRO,DGDTEND
  1.  S DGDIRA=" End with Date  :  "
  1.  S DGDIRB="TODAY"
  1.  S DGDIRH="^D HELP^DGPPRRPT(1)"
  1.  S DGDTEND=DGSORT("DGBEG")
  1.  S DGDIRO="DA^"_DGSORT("DGBEG")_":DT:EX"
  1.  S DGASK=$$ANSWER(DGDIRA,DGDIRB,DGDIRO,DGDIRH)
  1.  I DGASK>0 S DGSORT("DGEND")=DGASK
  1.  Q DGASK>0
  1.  ;
  1. ANSWER(DGDIRA,DGDIRB,DGDIR0,DGDIRH) ;
  1.  ; Input
  1.  ; DGDIR0 - DIR(0) string
  1.  ; DGDIRA - DIR("A") string
  1.  ; DGDIRB - DIR("B") string
  1.  ; DGDIRH - DIR("?") string
  1.  ; Output
  1.  ; Function Value - Internal value returned from ^DIR or -1 if user
  1.  ; up-arrows, double up-arrows or the read times out.
  1.  N X,Y,Z,DIR,DIROUT,DIRUT,DTOUT,DUOUT
  1.  I $D(DGDIR0) S DIR(0)=DGDIR0
  1.  I $D(DGDIRA) M DIR("A")=DGDIRA
  1.  I $G(DGDIRB)]"" S DIR("B")=DGDIRB
  1.  I $D(DGDIRH) S DIR("?")=DGDIRH,DIR("??")=DGDIRH
  1.  D ^DIR K DIR
  1.  S Z=$S($D(DTOUT):-2,$D(DUOUT):-1,$D(DIROUT):-1,1:"")
  1.  I Z="" S Z=$S(Y=-1:"",X="@":"@",1:$P(Y,U)) Q Z
  1.  I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q -1
  1.  Q $S(X="@":"@",1:$P(Y,U))
  1.  ;