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

DGOTHFSM.m

Go to the documentation of this file. 
  1. DGOTHFSM ;SLC/RM - FORMER OTH PATIENT ELIGIBILITY CHANGE REPORT ; July 13, 2020@09:44am
  1.  ;;5.3;Registration;**1025,1034,1035,1047**;Aug 13, 1993;Build 13
  1.  ;
  1.  ;Global References                       Supported by ICR#         Type
  1.  ;-----------------                       -----------------         ----------
  1.  ; ^DGPT("AFEE"                           418 (DG is the Cust.Pkg.) Cont. Sub.
  1.  ; ^TMP($J                                SACC 2.3.2.5.1
  1.  ;
  1.  ;External References
  1.  ;-------------------
  1.  ; HOME^%ZIS                               10086                    Supported
  1.  ; ^%ZISC                                  10089                    Supported
  1.  ; $$S^%ZTLOAD                             10063                    Supported
  1.  ; WAIT^DICD                               10024                    Supported
  1.  ; GETS^DIQ                                 2056                    Supported
  1.  ; ^DIR                                    10026                    Supported
  1.  ; $$CODEC^ICDEX                            5747                    Cont. Sub.
  1.  ; 2^VADPT,KVAR^VADPT                      10061                    Supported
  1.  ; $$SITE^VASITE                           10112                    Supported
  1.  ; $$FMADD^XLFDT,$$FMTE^XLFDT, $NOW^XLFDT  10103                    Supported
  1.  ; $$CJ^XLFSTR                             10104                    Supported
  1.  ; $$STA^XUAF4                              2171                    Supported
  1.  ; EN^XUTMDEVQ                              1519                    Supported
  1.  ; $$GET1^DIQ(45.7  1359,1154 (DG is the Custodial Package) Cont. Sub.,Supported
  1.  ;
  1.  ;No direct call
  1.  Q
  1.  ;
  1.  ;Entry point for DG FORMER OTH PATIENTS ELIG. CHANGE REPORT option
  1. MAIN ; Initial Interactive Processing
  1.  N DGSORT   ;array of report parameters
  1.  N ZTDESC,ZTQUEUED,ZTREQ,ZTSAVE,ZTSTOP,%ZIS
  1.  ;check for database
  1.  I '+$O(^DGOTH(33,"B","")) W !!!,$$CJ^XLFSTR(">>> No OTH records have been found. <<<",80) D ASKCONT(0) Q
  1.  W @IOF
  1.  W "FORMER OTH PATIENT ELIGIBILITY CHANGE REPORT"
  1.  W !!,"This report identifies Former Service Members whose Primary Eligibility"
  1.  W !,"changed from EXPANDED MH CARE NON-ENROLLEE to a new Primary Eligibility"
  1.  W !,"with a VERIFIED eligibility status. These patients are no longer treated"
  1.  W !,"under the Other Than Honorable (OTH) authority (VHA Directive 1601A.02)."
  1.  W !!,"*** THIS REPORT REQUIRES 132 COLUMN margin width ***"
  1.  W !!,"At the DEVICE: prompt, please accept the default value of '0;132;99999'"
  1.  W !,"to avoid wrapping of data."
  1.  W !!,"To include pagination, please use ';132;' for the device value."
  1.  W !!,"Enter Primary Eligibility Changed Date: "
  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 %ZIS=""
  1.  S %ZIS("B")="0;132;99999"
  1.  S ZTSAVE("DGSORT(")=""
  1.  S X="FORMER OTH PATIENT ELIGIBILITY CHANGE REPORT"
  1.  D EN^XUTMDEVQ("START^DGOTHFSM",X,.ZTSAVE,.%ZIS)
  1.  D HOME^%ZIS
  1.  Q
  1.  ;
  1. DATEFROM() ;prompt for FROM Date of Service
  1.  N DGASK,DGDIRA,DGDIRB,DGDIRH,DGDIRO,DGBEGDT,DGSTRTDT
  1.  S DGBEGDT=3200220 ;February 20,2020 is the date OTH project was released
  1.  S DGDIRA=" Start with Date:  "
  1.  S DGDIRB=$$FMTE^XLFDT(3200220)
  1.  S DGDIRH="^D HELP^DGOTHFSM(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^DGOTHFSM(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.  ;
  1. HELP(DGSEL) ;provide extended DIR("?") help text.
  1.  ; Input: DGSEL - prompt var for help text word selection
  1.  ; Output: none
  1.  N DGOTHDT
  1.  S DGOTHDT=3200220
  1.  I (X="?")!(X="??") D  Q
  1.  . W !,"  Enter the date when the former OTH patient has an Episode of Care"
  1.  . W !,"  or Released Prescription."
  1.  . W ! D HELP1
  1.  . W ! D HELP2
  1.  . I $D(Y) K Y
  1.  W !,"  The Date you entered is not valid."
  1.  I $D(Y),Y<DGOTHDT D HELP1 I $D(Y) K Y Q
  1.  I $D(Y),Y>DT D HELP2 I $D(Y) K Y Q
  1.  Q
  1.  ;
  1. HELP1 ;
  1.  W !,"  The earliest date that you can enter is February 20,2020."
  1.  W !,"  This is the date the new Primary Eligibility code"
  1.  W !,"  EXPANDED MH CARE NON-ENROLLEE became available."
  1.  Q
  1.  ;
  1. HELP2 ;
  1.  W !,"  Date cannot be a future date."
  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 DGLIST ;temp data storage used for report list
  1.  N DGOTHIN ;temp data storage for INACTIVE OTH patient list
  1.  N RECORD ;temp data storage for all records found in file #409.68,#52,#405,#350, and #399
  1.  N IBOTHSTAT
  1.  S DGLIST=$NA(^TMP($J,"OTHEL"))
  1.  S DGOTHIN=$NA(^TMP($J,"OTHINACTV"))
  1.  S RECORD=$NA(^TMP($J,"DGENCTR"))
  1.  S IBOTHSTAT=$NA(^TMP($J,"DGOTHFSM"))
  1.  K @DGLIST,@DGOTHIN,@RECORD,@IBOTHSTAT
  1.  D LOOP(.DGSORT,DGLIST,DGOTHIN)
  1.  I $O(@DGOTHIN@(""))'="" D PRINT(.DGSORT,DGLIST)
  1.  K @DGLIST,@DGOTHIN,@RECORD,@IBOTHSTAT
  1.  D EXIT
  1.  Q
  1.  ;
  1. LOOP(DGSORT,DGLIST,DGOTHIN) ;
  1.  N DDASH,DGPAGE,DGDFN,DGIEN33,DGERR,DGOTHARR,VAUTD,DATA,DGIBRX,SORTENCBY,DGOTHMST
  1.  N DGOTHREGDT,DGELIGDATE,DGPTNAME,DGNEWELG,DGPID,DGDOB,DGENCNT,DGELGDTV,DGMSTRSLT
  1.  S $P(DDASH,"=",81)=""
  1.  S (DGPAGE,SORTENCBY)=0
  1.  ;gather all registered OTH patients with INACTIVE status only
  1.  ;patients with INACTIVE OTH status, either the patient received VBA adjudication or entered in error
  1.  D INACTOTH(.DGSORT)
  1.  ;No INACTIVE OTH patients found, display message and quit
  1.  I $O(@DGOTHIN@(""))="" D  Q
  1.  . Q:'+$O(^DGOTH(33,"F",""))
  1.  . D HEADER,COLHEAD
  1.  . W !!!," >>> No records were found in the selected date range.",!!
  1.  . W ! D LINE
  1.  . D ASKCONT(0) W @IOF
  1.  ;Otherwise, loop thru all INACTIVE OTH patients temporarily stored in the global and see
  1.  ;which of this patients received primary eligibility status of VERIFIED
  1.  S VAUTD=1   ;All the divisions in the facility, since we are not prompting user to enter Division
  1.  S DGDFN="" F  S DGDFN=$O(@DGOTHIN@(DGDFN)) Q:DGDFN=""  D
  1.  . S DGIEN33="" F  S DGIEN33=$O(@DGOTHIN@(DGDFN,DGIEN33)) Q:DGIEN33=""  D
  1.  . . K DGERR,DGOTHARR,DATA,DGELIGDATE,DGPTNAME,DGNEWELG,DGOTHREGDT,DGPID,DGDOB,DGELGDTV
  1.  . . K @RECORD ;evaluate each patient one at a time
  1.  . . S DGENCNT=0,(DGMSTRSLT,DGOTHMST)=""
  1.  . . D GETS^DIQ(2,DGDFN_",",".01;.0905;.361;.3611;.3612","IE","DGOTHARR","DGERR") ;DG is the custodial package for file #2, no ICR needed
  1.  . . Q:$D(DGERR)
  1.  . . Q:$G(DGOTHARR(2,DGDFN_",",.3611,"I"))'="V"  ;quit if eligibility status not VERIFIED
  1.  . . S DGOTHREGDT=$G(@DGOTHIN@(DGDFN,DGIEN33)) ;the date when the patient became OTH
  1.  . . S DGELGDTV=$G(DGOTHARR(2,DGDFN_",",.3612,"I")) ;the date when the PE eligibility status of patient became VERIFIED
  1.  . . ;quit if not within the user specified date range
  1.  . . I (DGELGDTV<DGSORT("DGBEG"))!(DGOTHREGDT>DGSORT("DGEND")) Q
  1.  . . ;If patient had entries in file #409.68, #405, #350, #399, and #52 on the selected date range but
  1.  . . ;the SITE where the encounter happen does not belong to the facility/division where the report is run,
  1.  . . ;the patient will not be displayed/included in the report
  1.  . . ;for file #409.68 only collect completed encounter with STATUS=CHECKED OUT
  1.  . . D CHKTREAT^DGFSMOUT(+DGDFN,DGOTHREGDT,DGELGDTV,.VAUTD,0) ;check if there any past Outpatient Encounter entry in file #409.68
  1.  . . D CHECKPTF^DGFSMOUT(DGDFN,DGOTHREGDT,DGELGDTV,"DGOTHFSM") ;check if there any Inpatient stay entry in file #405 OR file #45
  1.  . . D CHECKIB^DGFSMOUT("DGOTHFSM",DGOTHREGDT,DGELGDTV) K ^TMP($J,"DGOTHFSM") ;check if this patient has records in file #350 or file #399
  1.  . . D CHECKRX^DGFSMOUT("DGOTHFSMRX") ;check at file #52 if this patient has any RX not yet charged
  1.  . . I $O(@RECORD@(""))="",DGENCNT<1 Q  ;do not include patient that has no record in any of these files: 409.68, 350, 399, 52, and file 405 OR file 45
  1.  . . ;if all checking above passed, then extract patient name,PID, New Eligibility Code, SC%, Eligibility Change Date, Station ID
  1.  . . S DGELIGDATE=$G(DGOTHARR(2,DGDFN_",",.3612,"I"))
  1.  . . S DGPTNAME=$G(DGOTHARR(2,DGDFN_",",.01,"I"))
  1.  . . S DGPID=$G(DGOTHARR(2,DGDFN_",",.0905,"I"))
  1.  . . S DGNEWELG=$G(DGOTHARR(2,DGDFN_",",.361,"E"))
  1.  . . S DATA=DGPTNAME_U_DGPID_U_DGOTHREGDT_U_DGNEWELG_U_DGELIGDATE
  1.  . . I $G(IBMST) D  ;extract the most current MST screening results for this patient
  1.  . . . S DGOTHMST=$$GETSTAT^DGMSTAPI(DGDFN)
  1.  . . . S DGMSTRSLT=$P(DGOTHMST,U,2),DGMSTRSLT=$S(DGMSTRSLT="Y":"YES",DGMSTRSLT="N":"NO",DGMSTRSLT="D":"DECLINE",DGMSTRSLT="U":"UNKNOWN",1:"NO DATA FOUND")
  1.  . . . I DGMSTRSLT="UNKNOWN",$P(DGOTHMST,U)<1 S DGMSTRSLT="NO DATA FOUND"
  1.  . . S DATA=$$SCPRCT(DGDFN,DATA) ;extract the SC%
  1.  . . D CHKINT(DATA) ;determine if the facility belongs to integrated or non-integrated site
  1.  Q
  1.  ;
  1. INACTOTH(DGSORT) ;Gather all registered OTH Patients with INACTIVE status within the user-specified date range
  1.  N DGDFN,DGIEN33,DGERR,DGOTHARR,DGREGDT,DGOTHELDT,DGRECNUM,DGFOUND,DGELGDT,DGSTDT,II,DGTOTREC
  1.  ;check first the existence of the "F" cross reference
  1.  I '+$O(^DGOTH(33,"F","")) W !!!,$$CJ^XLFSTR(">>> The ""F"" cross reference use to run the report does not exist . <<<",80) D ASKCONT(0) Q
  1.  ;only extract INACTIVE OTH patients within the user-specified date range
  1.  ;this is to ensure for fast data extraction
  1.  ;EXEMPTION (only do this process): If the user's starting date is February 20, 2020 but the OTH patient
  1.  ;                                  had previous information stored in File #33, go ahead and include that patient
  1.  ;check if starting date is February 20, 2020 - if true, reset the starting date to the OTH legislation date to Jul 01, 2017
  1.  ;loop thru cross reference "F" to run report
  1.  I DGSORT("DGBEG")=3200220 S DGSTDT=3170701
  1.  E  S DGSTDT=DGSORT("DGBEG")
  1.  S DGOTHELDT=$$FMADD^XLFDT(DGSTDT,-1)
  1.  F  S DGOTHELDT=$O(^DGOTH(33,"F",DGOTHELDT)) Q:DGOTHELDT=""!((DGOTHELDT\1)>DGSORT("DGEND"))  D
  1.  . K DGERR,DGOTHARR,DGOTHREGDT,DGREGDT,DGIEN33
  1.  . S DGIEN33=+$O(^DGOTH(33,"F",DGOTHELDT,""))
  1.  . ;find only those INACTIVE OTH patients whose registration date falls within the user-specified date range
  1.  . ;either these patients received adjudication or the PE is entered in error
  1.  . D GETS^DIQ(33,DGIEN33_",",".01;.02;2*","IE","DGOTHARR","DGERR")
  1.  . Q:$D(DGERR)
  1.  . Q:$G(DGOTHARR(33,DGIEN33_",",.02,"I"))  ;quit if status is ACTIVE
  1.  . ;loop through all the OTH Registration Date and determine the original date the former OTH service member become EXPANDED MH CARE NON-ENROLLEE
  1.  . S (DGFOUND,DGTOTREC)=0
  1.  . S DGTOTREC=$P(^DGOTH(33,DGIEN33,2,0),U,4)
  1.  . Q:+DGTOTREC<1
  1.  . F II=1:1:DGTOTREC S DGREGDT(II)=""
  1.  . S DGRECNUM="" F  S DGRECNUM=$O(DGREGDT(DGRECNUM)) Q:DGRECNUM=""!(DGFOUND)  D
  1.  . . I DGOTHARR(33.02,DGRECNUM_","_DGIEN33_",",.02,"E")="EXPANDED MH CARE NON-ENROLLEE" D  ;check if the eligibility is EXPANDED MH CARE NON-ENROLLEE
  1.  . . . ;the original OTH registration date
  1.  . . . S DGOTHREGDT=$G(DGOTHARR(33.02,DGRECNUM_","_DGIEN33_",",.01,"I"))
  1.  . . . S DGDFN=$G(DGOTHARR(33,DGIEN33_",",.01,"I"))
  1.  . . . S @DGOTHIN@(DGDFN,+DGIEN33)=DGOTHREGDT\1
  1.  . . . S DGFOUND=1
  1.  Q
  1.  ;
  1. SCPRCT(DFN,DATA) ;extract the service connected percentage
  1.  N VAEL,VADM,DGDOB,VA
  1.  D 2^VADPT ;extract patients demographics and eligibility information
  1.  S DGDOB=$P(VADM(3),U)
  1.  S DATA=DATA_U_$P(VAEL(3),"^",2)_U_DGDOB_U
  1.  D KVAR^VADPT
  1.  Q DATA
  1.  ;
  1. CHKINT(DATA) ; check for integrated site divisions
  1.  N INTFCLTY,DGDIV,DGSTATN,OLDSTA,DGENCTRDT,RECNT,FILENO
  1.  S OLDSTA=""
  1.  S INTFCLTY="^528^589^636^657^" ; list of integrated site parent facilities (station #s)
  1.  S DGENCTRDT="" F  S DGENCTRDT=$O(@RECORD@(DGENCTRDT)) Q:DGENCTRDT=""  D
  1.  . S DGDIV="" F  S DGDIV=$O(@RECORD@(DGENCTRDT,DGDIV)) Q:DGDIV=""  D
  1.  . . S FILENO="" F  S FILENO=$O(@RECORD@(DGENCTRDT,DGDIV,FILENO)) Q:FILENO=""  D
  1.  . . . S RECNT="" F  S RECNT=$O(@RECORD@(DGENCTRDT,DGDIV,FILENO,RECNT)) Q:RECNT=""  D
  1.  . . . . S DGSTATN=$P(@RECORD@(DGENCTRDT,DGDIV,FILENO,RECNT),U,2)
  1.  . . . . Q:DGSTATN=""
  1.  . . . . ;only extract station # belong to the facility/division where the report is run
  1.  . . . . Q:+DGSTATN'=+$P(HERE,U,3)
  1.  . . . . I INTFCLTY[(U_+DGSTATN_U) D  Q
  1.  . . . . . ;if integrated facility, display all station # patient was treated
  1.  . . . . . S @DGLIST@(DGPTNAME,DGDFN,DGSTATN)=DATA_U_DGMSTRSLT
  1.  . . . . ;roll up the station to its site parent facilities e.g. 442,442GA,442GC - this will roll up to 442
  1.  . . . . I OLDSTA'=+DGSTATN S @DGLIST@(DGPTNAME,DGDFN,+DGSTATN)=DATA_U_DGMSTRSLT
  1.  . . . . S OLDSTA=+DGSTATN
  1.  Q
  1.  ;
  1. PRINT(DGSORT,DGLIST) ;output report
  1.  N DGPAGE,DDASH,DGQ,DGDFN,DGTOTAL,DGPRINT,DGOLD,DGSTATN,DGPTNAME
  1.  S (DGQ,DGTOTAL,DGPAGE,DGPRINT,DGOLD)=0,$P(DDASH,"=",81)=""
  1.  I $O(@DGLIST@(""))="" D  Q
  1.  . D HEADER,COLHEAD
  1.  . W !!!," >>> No records were found using the report criteria.",!!
  1.  . W ! D LINE
  1.  . D ASKCONT(0) W @IOF
  1.  ; loop and print report
  1.  D HEADER,COLHEAD
  1.  S DGPTNAME="" F  S DGPTNAME=$O(@DGLIST@(DGPTNAME)) Q:DGPTNAME=""  D  Q:DGQ
  1.  . I DGOLD'=DGPTNAME S DGPRINT=0
  1.  . S DGDFN="" F  S DGDFN=$O(@DGLIST@(DGPTNAME,DGDFN)) Q:DGDFN=""  D  Q:DGQ
  1.  . . S DGSTATN="" F  S DGSTATN=$O(@DGLIST@(DGPTNAME,DGDFN,DGSTATN)) Q:DGSTATN=""  D  Q:DGQ
  1.  . . . I $Y>(IOSL-4) W ! D LINE D PAUSE(.DGQ) Q:DGQ  D HEADER,COLHEAD
  1.  . . . W !
  1.  . . . I 'DGPRINT D PRINT1 S DGPRINT=1
  1.  . . . W ?$S($G(IBMST):48,1:54),$$FMTE^XLFDT($P(@DGLIST@(DGPTNAME,DGDFN,DGSTATN),U,3),"5Z") ;OTH registration date
  1.  . . . W ?$S($G(IBMST):60,1:69),$P(@DGLIST@(DGPTNAME,DGDFN,DGSTATN),U,4) ;new primary eligibility code
  1.  . . . I $G(IBMST) W ?91,$P(@DGLIST@(DGPTNAME,DGDFN,DGSTATN),U,9) ;user wants to display the current MST status date for a patient}
  1.  . . . W ?$S($G(IBMST):107,1:103),$P(@DGLIST@(DGPTNAME,DGDFN,DGSTATN),U,6) ;SC%
  1.  . . . W ?$S($G(IBMST):112,1:110),$$FMTE^XLFDT($P(@DGLIST@(DGPTNAME,DGDFN,DGSTATN),U,5),"5Z") ;primary eligibility changed date
  1.  . . . W ?125,DGSTATN
  1.  . . . Q:DGQ
  1.  . . Q:DGQ
  1.  . S DGTOTAL=DGTOTAL+1
  1.  . Q:DGQ
  1.  . S DGOLD=DGPTNAME
  1.  Q:DGQ
  1.  W !
  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. PRINT1 ;print the name, pid, and DOB only once
  1.  W $E($P(@DGLIST@(DGPTNAME,DGDFN,DGSTATN),U,1),1,$S($G(IBMST):27,1:30)) ;patient name
  1.  W ?$S($G(IBMST):29,1:33),$$FMTE^XLFDT($P(@DGLIST@(DGPTNAME,DGDFN,DGSTATN),U,7),"5Z") ;DOB
  1.  W ?$S($G(IBMST):41,1:46),$P(@DGLIST@(DGPTNAME,DGDFN,DGSTATN),U,2) ;PID
  1.  Q
  1.  ;
  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 !,?44,$G(ZTDESC),?120,"Page: ",?127,DGPAGE
  1.  W ! D LINE
  1.  W !,"OTH Eligibility Change Date Range: ",?12,$$FMTE^XLFDT(DGSORT("DGBEG"),"5Z")_" TO "_$$FMTE^XLFDT(DGSORT("DGEND"),"5Z")
  1.  W ?92,"Date Printed  : ",$$FMTE^XLFDT($$NOW^XLFDT,"MP")
  1.  W !!,"List of Patients whose primary eligibility changed from EXPANDED MH CARE NON-ENROLLEE to a new primary eligibility code with"
  1.  W !,"eligibility status of VERIFIED and episode(s)of care.",!
  1.  I $G(IBMST) W !,"The Current MST Screening indicates the latest MST screening result for the patient."
  1.  W !,"The Station column provides data on which site(s) the patient was treated."
  1.  W ! D LINE W !
  1.  Q
  1.  ;
  1. LINE ;prints double dash line
  1.  N LINE
  1.  F LINE=1:1:132 W "="
  1.  Q
  1.  ;
  1. COLHEAD ;report column header
  1.  I $G(IBMST) D  Q  ;user wants the MST Information to be displayed
  1.  . W "PATIENT NAME",?29,"DATE OF",?41,"PID",?48,"OTH REG",?60,"NEW ELIGIBILITY CODE",?91,"CURRENT MST",?107,"SC%",?112,"ELIGIBILITY",?125,"STATION"
  1.  . W !,?29,"BIRTH",?48,"DATE",?91,"SCREEN STATUS",?112,"CHANGE DATE"
  1.  . W !,"---------------------------",?29,"----------",?41,"-----",?48,"----------",?60,"-----------------------------"
  1.  . W ?91,"--------------",?107,"---",?112,"-----------",?125,"-------"
  1.  W "PATIENT NAME",?33,"DATE OF",?46,"PID",?54,"OTH REG DATE",?69,"NEW ELIGIBILITY CODE",?103,"SC%",?110,"ELIGIBILITY",?125,"STATION"
  1.  W !,?33,"BIRTH",?110,"CHANGE DATE"
  1.  W !,"------------------------------",?33,"----------",?46,"-----",?54,"------------"
  1.  W ?69,"------------------------------",?103,"----",?110,"-----------",?125,"-------"
  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. CHKDATE(DATE,BEGDT,ENDDT) ;check if dates fall within the Begin and End dates
  1.  Q BEGDT<=DATE&(ENDDT>=DATE)
  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.  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.  I $D(ZTQUEUED) S ZTREQ="@"  ;tell TaskMan to delete Task log entry
  1.  I '$D(ZTQUEUED) D
  1.  . I 'TRM,$Y>0 W @IOF
  1.  . K %ZIS,POP
  1.  . D ^%ZISC,HOME^%ZIS
  1.  Q
  1.  ;
  1. PTFDATA ;extract data for the inpatient
  1.  ;If patient still not discharged (still in the hospital)extract the ward location in Patient file #2,otherwise, extract the ward at discharge in file #45
  1.  N PRIMDX,PTFIEN405
  1.  S PRIMDX="NONE"
  1.  I DSCHRGDT>0 D  ;patient is discharged
  1.  . S WRDLOC=$$GET1^DIQ(45,PTFIEN_",",2.2,"E") ;ward location discharge
  1.  . S TRTFCLTY="*DISCH("_$$FMTE^XLFDT($P(DSCHRGDT,".")\1,"5ZF")_")" ;treating facility
  1.  E  D
  1.  . S WRDLOC=$G(^DPT(DGDFN,.1)) ;ward location
  1.  . S TRTFCLTY=$$GET1^DIQ(45.7,+$G(^DPT(DGDFN,.103))_",",.01,"E") ;treating facility - DG is the custodial package for file #45.7, no icr needed
  1.  S WRDLOC=$S(WRDLOC'="":WRDLOC,1:"NON-VA ADMISSION")
  1.  D ATID1^DGOTHFS4 ;extract the ward and the last user edited the record in file #405
  1.  I $D(^DGPT(PTFIEN,70)) D  ;Extract primary diagnosis if there are any
  1.  . S PRIMDX=$P(^DGPT(PTFIEN,70),U,10)
  1.  . S PRIMDX=$$CODEC^ICDEX(80,PRIMDX)
  1.  . S PRIMDX=$S($P(PRIMDX,U)=-1:"NONE",1:PRIMDX)
  1.  I $D(^DGPT("AFEE",DGDFN,ADMDT,PTFIEN)) D  ;check if this record is a NONVA transaction
  1.  . I '$G(^DGPT(PTFIEN,70)) S PRIMDX="NONE" ;this is to exit the routine gracefully. Some inpatient episode of care does not have primary dx listed
  1.  . I PRIMDX="NONE",$G(^DGPT(PTFIEN,70))'="" S PRIMDX=$P(^DGPT(PTFIEN,70),U,10),PRIMDX=$$CODEC^ICDEX(80,PRIMDX),PRIMDX=$S($P(PRIMDX,U)=-1:"NONE",1:PRIMDX)
  1.  . I DGSTA="" D
  1.  . . K DGOUT,DGOUTERR D GETS^DIQ(45,PTFIEN_",","3","IE","DGOUT","DGOUTERR")
  1.  . . S DGSTA=DGOUT(45,PTFIEN_",",3,"I")
  1.  . . I DGSTA="" S DGSTA="NON-VA"
  1.  . . S DGDIVNME="NON-VA HOSPITAL"
  1.  . . I LSTUSR="" S LSTUSR="N/A"
  1.  . S WRDLOC="NON-VA ADMISSION",TRTFCLTY=$S($G(DSCHRGDT)>0:TRTFCLTY,1:"NON-VA FACILITY")
  1.  I $G(DGDIVNME)="" S DGDIVNME="NONE" I $G(DGDIV)="" S DGDIV="NONE"
  1.  I $G(DGSTA)="" S DGSTA="NONE" I $G(LSTUSR)="" S LSTUSR="NONE ENTERED"
  1.  ;the 0 at the end of TMPDATA designates that the is inpatient
  1.  S TMPDATA=DGDIVNME_U_DGSTA_U_WRDLOC_U_$S(TRTFCLTY'="":TRTFCLTY,1:"N/A")_U_LSTUSR_U_DGDIV_U_""_U_PTFIEN405_";"_PTFIEN_U_PRIMDX_U_0
  1.  S DGENCNT=DGENCNT+1
  1.  S @RECORD@(ADMDT,DGSTA,405,DGENCNT)=TMPDATA ;sort by date of service
  1.  I SORTENCBY=2 S @RECORD1@(DGSTA,ADMDT,405,DGENCNT)=TMPDATA ;sort by division
  1.  K DGOUT,DIVINPT
  1.  Q
  1.  ;