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