DGOTHFS2 ;SLC/RM - FORMER OTH PATIENT DETAIL REPORT 2 ; July 30,2020@09:44am
;;5.3;Registration;**1025,1034,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
; EN^IBEFSMUT 7202 DG has permission to access) Private
; RX^PSO52API 4820 Supported
; 2^VADPT 10061 Supported
; KVAR^VADPT 10061 Supported
; $$SITE^VASITE 10112 Supported
; $$FMTE^XLFDT 10103 Supported
; $$CJ^XLFSTR 10104 Supported
; EN^XUTMDEVQ 1519 Supported
;
;No direct call
Q
;
;Entry point for DG FORMER OTH PATIENTS DETAIL REPORT option
MAIN ; Initial Interactive Processing
N DGSORT,IBOTHSTAT ;array of report parameters
N ZTDESC,ZTQUEUED,ZTREQ,ZTSAVE,ZTSTOP,DGPTNM,DGMTS,VAUTD,%ZIS,DGENCNT,SORTENCBY,DGRTNSTCK,DGPRTLRXFL
N INACTIVE,DGDFN,DFN,VAEL,VADM,VA,I3,DGPID,DGPAGE,DGRPTSRT,DGTOTALRX,IBOTHSTAT,DGTOTRX52
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
;check for database
I '+$O(^DGOTH(33,"B","")) W !!!,$$CJ^XLFSTR(">>> No OTH records have been found. <<<",80) D ASKCONT^DGOTHFSM(0) Q
W @IOF
S (INACTIVE,DGRPTSRT,DGRTNSTCK,DGPRTLRXFL)=0,SORTENCBY=2
W "FORMER OTH PATIENT DETAIL REPORT",!!
W "This option assists billing user in reviewing Former Service Member's past"
W !,"episodes of care and released prescription details to determine if"
W !,"potential back-billing is necessary."
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:'INACTIVE!(DGSORT'>0)
D RECALL^DILFD(33,+DGSORT_",",DUZ)
;Prompt user what type of data/report user wish to see
;user had two options: Eligibility or Encounters
I '$$RPTTYPE Q
S RECORD=$NA(^TMP($J,"DGOTHFSDOS"))
S RECORD1=$NA(^TMP($J,"DGOTHFSDIV"))
S IBOTHSTAT=$NA(^TMP($J,"IBOTHSTAT"))
K @RECORD ;temp data storage for all records found in file #409.68,and #405 sorted by date of service
K @RECORD1 ;temp data storage for all records found in file #409.68,and #405 sorted by division
K ^TMP($J,"OTHFSMR2") ;patient's RX information from File #52
K ^TMP($J,"OTHFSMRX") ;temporary storage for all Rx information and IB status ready for printing report
K @IBOTHSTAT ;temp storage for file #350 and file # 399 IB status
;if user select report type ALL, prompt user how it will be sorted
;do not continue, if user does not select any sorting
I DGSORT("RTYPE")="A" D Q:DGRPTSRT<1
. ;determine first the original date the former OTH service member become EXPANDED
. ;MH CARE NON-ENROLLEE and loop through all the OTH Registration Date
. S DGIEN33=DGSORT,(DGENCNT,DGTOTALRX,DGTOTRX52,DGRTNSTCK,DGPRTLRXFL)=0
. S DGSORT("DGBEG")=$$OTHREGDT(DGIEN33) ;the date when the patient became OTH
. S DGSORT("DGEND")=$$GET1^DIQ(2,DGDFN_",",.3612,"I") ;the date when the PE eligibility status of patient became VERIFIED
. S VAUTD=1 ;All the divisions in the facility, since we are not prompting user to enter Division
. 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"),"IBOTHSTAT") ;check if there any Inpatient stay entry in file #405
. D CHECKIB^DGFSMOUT("IBOTHSTAT",DGSORT("DGBEG"),DGSORT("DGEND")) ;check if this patient has records in file #350 or file #399
. D RX^PSO52API(DGDFN,"OTHFSMR2",,,"2,R,P",DGSORT("DGBEG"),$$FMADD^XLFDT(DGSORT("DGEND"),366)) ;get the medication profile of a patient from PRESCRIPTION file (#52)
. ;before moving forward remove RX data from the patient's episode of care array first
. I $O(@RECORD@(""))'="" D FLTRENC^DGOTHFS4 ;determines whether to prompt Encounter sorting
. I DGTOTALRX<2 S DGTOTRX52=+$P(^TMP($J,"OTHFSMR2",DGDFN,0),U) I +DGTOTRX52>0 D TOTRX^DGOTHFS4 ;determines whether to prompt the Rx sorting and see if the Rx released date is within the date range
. S DGTOTALRX=DGTOTALRX+DGTOTRX52
. I $O(@IBOTHSTAT@(""))="" D EN^IBEFSMUT(DGDFN,DGSORT("DGBEG"),DGSORT("DGEND"),"IBOTHSTAT") ;extract in advance the IB STATUS in both file #350 and file #399
. I (DGENCNT>1),(DGTOTALRX>1) D Q
. . W !!,"Please select sorting order for Episodes of Care and Released Prescription",!,"report section:"
. . ;prompt user how the Encounter report section will be sorted
. . I '$$SORTENC^DGOTHFS3 Q
. . ;prompt user Rx report section will be sorted
. . I '$$SORTRX^DGOTHFS3 Q
. . S DGRPTSRT=1
. I (DGENCNT>1),(DGTOTALRX<2) D Q
. . W !!,"Please select sorting order for Episodes of Care report section:"
. . I '$$SORTENC^DGOTHFS3 Q
. . S DGRPTSRT=1,DGSORT("SORTRXBY")=1
. I (DGENCNT<2),(DGTOTALRX>1) D Q
. . W !!,"Please select sorting order for Released Prescription report section:"
. . I '$$SORTRX^DGOTHFS3 Q
. . S DGRPTSRT=1
. . S DGSORT("SORTENCBY")=1
. S DGSORT("SORTENCBY")=1,DGSORT("SORTRXBY")=1
. S DGRPTSRT=1
W !!
S %ZIS=""
S %ZIS("B")="0;132;"
S ZTSAVE("DGSORT(")=""
S ZTSAVE("DGSORT")=""
S ZTSAVE("DGDFN")=""
S ZTSAVE("DGPTNM")=""
S ZTSAVE("DGTOTALRX")=""
S X="FORMER OTH PATIENT ELIGIBILITY CHANGE REPORT"
D EN^XUTMDEVQ("START^DGOTHFS2",X,.ZTSAVE,.%ZIS)
D HOME^%ZIS
Q
;
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")
S (DGQ,DGPAGE,I3)=0
S DGIEN33=DGSORT
S DFN=DGDFN
S DGPID=$$GET1^DIQ(2,DFN_",",.0905,"I")
;display the patient's current and verified eligibility
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
;display patient's all Primary Eligibility history
D HISTORY(DGIEN33)
Q:DGQ
;if user wants to see patient Encounter and Rx information
I DGSORT("RTYPE")="A" D
. ;display patient's checked out Encounters and inpatient data
. D ENCTR(DGDFN,.DGSORT)
. Q:DGQ
. ;display patient's Released Prescriptions
. D RX(DGDFN,.DGSORT)
D KVAR^VADPT
K @RECORD,@RECORD1,@IBOTHSTAT,^TMP($J,"OTHFSMR2"),^TMP($J,"OTHFSMRX")
D EXIT^DGOTHFSM
Q
;
PROMPTPT ;prompt user to enter patient
;keep prompting for patient name until user enter patient with INACTIVE status
F D Q:INACTIVE
. ;Prompt user for OTH patient name
. S DGPTNM=$$SELPAT(.DGSORT)
. I DGSORT'>0 S INACTIVE=1 Q
. I $$ACTIVE(.DGSORT) D Q
. . W !!,"The patient you selected is still PENDING for VBA Adjudication."
. . D RUNOPT
. ;if INACTIVE STATUS, check if the eligibility status is VERIFIED
. S DGDFN=$P(DGSORT(0),U)
. I $$GET1^DIQ(2,DGDFN_",",.3611,"I")'="V" D Q
. . W !!,"The primary eligibility status of the patient you selected is not VERIFIED."
. . D RUNOPT
. S INACTIVE=1
Q
;
RUNOPT ;display message to run FORMER OTH PATIENT ELIGIBILITY CHANGE REPORT option
W !,"Please run FORMER OTH PATIENT ELIGIBILITY CHANGE REPORT option"
W !,"to identify Former OTH Service Member whose Primary Eligibility"
W !,"changed from EXPANDED MH CARE NON-ENROLLEE to a new Primary"
W !,"Eligibility with a VERIFIED eligibility status.",!
Q
;
ACTIVE(DGSORT) ;determine the current status of OTH patient
;return 0 for INACTIVE
;otherwise, 1 for ACTIVE
N DGIEN33,DGOTHSTAT
S DGIEN33=DGSORT
S DGOTHSTAT=$$GET1^DIQ(33,DGIEN33_",",.02,"I")
Q DGOTHSTAT
;
SELPAT(DGSORT) ;prompt for veteran's name
;- input vars for ^DIC call
N DIC,DTOUT,DUOUT,X,Y
S DIC="^DGOTH(33,",DIC(0)="AEMQZV"
S DIC("A")="Enter Patient Name: "
S DIC("?PARAM",33,"INDEX")="B"
S DIC("?N",33)=12
;- 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, Episodes of Care, Prescription)"
S DGASK=$$ANSWER^DGOTHFSM(DGDIRA,DGDIRB,DGDIRO,DGDIRH)
I DGASK="E"!(DGASK="A") S DGSORT("RTYPE")=DGASK,DGASK=1
E S DGASK=0
Q DGASK
;
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("FORMER OTH PATIENT DETAIL REPORT")
D LINE(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,DGDFN_",",.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"
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(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(.DGQ) Q:DGQ D PTHDR,LINE(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(.DGQ) Q:DGQ D PTHDR,LINE(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 !
Q
;
HISTORY(IEN33) ;extract all eligibility history
N DGELHIST,DGOTHIST,DGRECNUM,DGLINE,DGOTHTYP
;display this piece of information to its own page so that the report will not look cluttered
D PAUSE(.DGQ) Q:DGQ D PTHDR,LINE(0) W !
D HDR(0)
W !
K DGOTHIST
S DGELHIST=$$CROSS^DGOTHINQ(IEN33,.DGOTHIST)
;go through all the eligibility history and only display date starting from Feb. 20,2020
;3200220 is the Release Date of EXPANDED MH CARE NON-ENROLLEE
S DGRECNUM="" F S DGRECNUM=$O(DGOTHIST(IEN33,DGRECNUM)) Q:DGRECNUM="" D Q:DGQ
. I $Y>(IOSL-4) W ! D PAUSE(.DGQ) Q:DGQ D PTHDR,LINE(0) W !! D HDR(1)
. S DGLINE=DGOTHIST(IEN33,DGRECNUM)
. S DGOTHTYP=$$OTHTYP^DGOTHINQ($P(DGLINE,U))
. W $S($P(DGLINE,U)="":"UNKNOWN",+DGOTHTYP:"EXPANDED MH CARE NON-ENROLLEE"_" ("_$P(DGLINE,U)_")",1:$P(DGLINE,U))
. I $P(DGLINE,U)="EXPANDED MH CARE NON-ENROLLEE" W " (N/A)"
. W ?60,$$FMTE^XLFDT($P(DGLINE,U,2),"5Z")
. W !
;break before going back to parent menu
I DGSORT("RTYPE")="E" W !!,"<< end of report >>" D ASKCONT^DGOTHFSM(0) W @IOF
Q
;
OTHREGDT(DGIEN33) ;determine the original date the former OTH service member become EXPANDED MH CARE NON-ENROLLEE
;return the original OTH registration date
N DGFOUND,DGTOTREC,DGRECNUM,DGOTHARR,DGOTHREGDT,DGERR,DGREGDT,II
S (DGFOUND,DGTOTREC,DGOTHREGDT)=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
. K DGOTHARR,DGERR
. D GETS^DIQ(33,DGIEN33_",","2*","IE","DGOTHARR","DGERR")
. Q:$D(DGERR)
. ;check if the eligibility is EXPANDED MH CARE NON-ENROLLEE
. I DGOTHARR(33.02,DGRECNUM_","_DGIEN33_",",.02,"E")="EXPANDED MH CARE NON-ENROLLEE" D
. . ;the original OTH registration date
. . S DGOTHREGDT=$G(DGOTHARR(33.02,DGRECNUM_","_DGIEN33_",",.01,"I"))
. . S DGFOUND=1
Q DGOTHREGDT\1
;
ENCTR(DFN,DGSORT) ;display patient's episodes of care
N DGDIV,DGENCTRDT,DGTOTENC,SUB1,SUB2,JJ,DGENCTRIB,FILENO,STAT350,STAT399,BILLNO,ACRTYP,CHRGCNT,PRINTRPT
;display this piece of information to its own page so that the report will not look cluttered
D PAUSE(.DGQ) Q:DGQ D PTHDR,LINE(0)
D ENCHDR(0),ENCTRCOL,LINE(1)
S (DGTOTENC,PRINTRPT)=0
I $O(@RECORD@(""))="" D
. W !!,">> NO DATA FOUND FROM "_$$FMTE^XLFDT(DGSORT("DGBEG"),"5ZF")_" TO "_$$FMTE^XLFDT(DGSORT("DGEND"),"5ZF")_"."
. W ! D LINE(1)
. Q:DGQ
. W !!,"Total Number of Encounter: ",DGTOTENC
E D
. I 'PRINTRPT D
. . I $P(DGSORT("SORTENCBY"),U)=2 D
. . . K @RECORD
. . . M @RECORD=@RECORD1
. . . K @RECORD1
. . D ENCTRIB^DGOTHFS3 ;extract the IB status
. . S PRINTRPT=1
. D ENCTRIB^DGOTHFS3 ;use the same loop to display status
Q
;
ENCTRCOL ;display encounter column name
W !,"Location of",?22,"Clinic Stop/",?45,"Primary",?55,"Div.",?61,"Date of",?72,"Last Updated",?89,"Bill #",?100,"Action Type/",?116,"IB Status"
W !,"Care",?22,"Treating Specialty",?45,"DX",?61,"Service",?77,"By",?100,"Rate Type",!
Q
;
ENCHDR(FLAG) ;Encounter Header
N TITLE
S TITLE="PATIENT'S EPISODE OF CARE"_$S(FLAG:" - Continuation",1:"")
W !,?132-$L(TITLE)\2,TITLE,!
D DTRANGE
S TITLE="Sorted By: "_$E($P(DGSORT("SORTENCBY"),U,2),4,20)
I $P(DGSORT("SORTENCBY"),U,2)'="" W ?132-$L(TITLE)\2,TITLE,!
D LINE(1)
Q
;
DTRANGE ;display date range
N DTRANGE
S DTRANGE="Date Range: "_$$FMTE^XLFDT(DGSORT("DGBEG"),"5ZF")_" - "_$$FMTE^XLFDT(DGSORT("DGEND"),"5ZF")
W ?132-$L(DTRANGE)\2,DTRANGE,!
Q
;
RX(DFN,DGSORT) ;extract patient's released prescription
N FILENO,OTHIBDT,OTHIBREC,ACCTYP,RESULT,CNTR,OTHIBRX
;display this piece of information to its own page so that the report will not look cluttered
D PAUSE(.DGQ) Q:DGQ D PTHDR,LINE(0)
;traverse ^TMP($J,"IBOTHSTAT" if the dates listed exist
;in the ^TMP($J,"OTHFSMR2", this is where all the RX's of the patient
;is stored.
S CNTR=0
F FILENO=350,399 D Q:DGQ
. Q:$P(^TMP($J,"IBOTHSTAT",FILENO,DFN,0),U)<1
. S OTHIBDT="" F S OTHIBDT=$O(^TMP($J,"IBOTHSTAT",FILENO,OTHIBDT)) Q:OTHIBDT="" D Q:DGQ
. . S OTHIBREC="" F S OTHIBREC=$O(^TMP($J,"IBOTHSTAT",FILENO,OTHIBDT,DFN,OTHIBREC)) Q:OTHIBREC="" D Q:DGQ
. . . ;quit if not within the date range selected by the user
. . . Q:'$$CHKDATE(OTHIBDT,.DGSORT)
. . . I FILENO=350 D Q:ACCTYP'["RX"
. . . . S ACCTYP=$P(^TMP($J,"IBOTHSTAT",FILENO,OTHIBDT,DFN,OTHIBREC),U)
. . . I FILENO=399 D Q:$P(ACCTYP,U)'=3
. . . . S ACCTYP=$P($P($P(^TMP($J,"IBOTHSTAT",FILENO,OTHIBDT,DFN,OTHIBREC),U,5),";"),":")
. . . S RESULT=$P(^TMP($J,"IBOTHSTAT",FILENO,OTHIBDT,DFN,OTHIBREC),U,5)
. . . I $P(RESULT,":")=52 S OTHIBRX=+$P(RESULT,":",2) ;file #350 RX IEN
. . . I $P(RESULT,":")=350 S OTHIBRX=0
. . . I ACCTYP=3 S OTHIBRX=$P(RESULT,":",3) ;file #399 RX IEN
. . . D RX1^DGOTHFS3
. . Q:DGQ
. Q:DGQ
I DGQ K ^TMP($J,"OTHFSMR2"),^TMP($J,"OTHFSMRX") Q
D RXNOSTAT^DGOTHFS3 ;Extract those RX's that has not been charge
D PRINTRX^DGOTHFS4
K ^TMP($J,"OTHFSMR2"),^TMP($J,"OTHFSMRX")
W !!,"<< end of report >>"
Q:DGQ
D ASKCONT^DGOTHFSM(0) W @IOF
Q
;
LINE(FLAG) ;prints double dash line
N LINE
I FLAG<1 F LINE=1:1:132 W "="
E F LINE=1:1:132 W "-"
Q
;
PTHDR(TITLE) ;patient name and DOB header
S TITLE=$G(TITLE)
I $G(TRM)!('$G(TRM)&DGPAGE) W @IOF
I $L(TITLE) W ?132-$L(TITLE)\2,TITLE W !!
S DGPAGE=$G(DGPAGE)+1
W "Patient Name: ",DGPTNM_" ("_DGPID_")",?112,"DOB: ",$P(VADM(3),U,2),!
Q
;
HDR(FLAG) ;Primary Eligibility History header
N TITLE
S TITLE="PRIMARY ELIGIBILITY/EXPANDED CARE TYPE HISTORY"_$S(FLAG:" - Continuation",1:"")
W ?132-$L(TITLE)\2,TITLE,!
D LINE(1)
W "Primary Eligibility",?60,"Date of Change",!
D LINE(1)
Q
;
PAUSE(DGQ) ; pause screen display
N J
I $Y<(IOSL-4) D
. F J=1:1 Q:($Y>(24-4)) W !
I $G(DGPAGE)>0,TRM,$$E("Press <Enter> to continue or '^' to exit:")<1 S DGQ=1
Q
;
E(MSG) ; ----- ask user to press enter to continue
; Return: -2:Time-out; -1:'^'-out 1:anything else
S MSG=$G(MSG)
N X,Y,Z,DIR,DIROUT,DIRUT,DTOUT,DUOUT
S DIR(0)="EA"
I $L(MSG) S DIR("A")=MSG
D ^DIR
S X=$S($D(DTOUT):-2,$D(DUOUT):-1,1:1)
Q X
;
HELP ;provide extended DIR("?") help text.
I (X="?")!(X="??") D
. W !,"Select ""E""ligibility if you wish to see the Primary Eligibility history"
. W !," Means Test, and Health Insurance information of the selected"
. W !," patient.",!
. W !,"Select ""A""ll if you wish to see the Primary Eligibility history,"
. W !," Means Test, Health Insurance information, Patient's"
. W !," Episodes of Care, and patient's Released Prescriptions"
. W !," of the selected patient.",!
Q
;
CHKDATE(DATE,DGSORT) ;check if dates fall within the Begin and End dates
Q DGSORT("DGBEG")<=DATE&(DGSORT("DGEND")>=DATE)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGOTHFS2 19426 printed Sep 23, 2025@20:22:41 Page 2
DGOTHFS2 ;SLC/RM - FORMER OTH PATIENT DETAIL REPORT 2 ; July 30,2020@09:44am
+1 ;;5.3;Registration;**1025,1034,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 ; EN^IBEFSMUT 7202 DG has permission to access) Private
+25 ; RX^PSO52API 4820 Supported
+26 ; 2^VADPT 10061 Supported
+27 ; KVAR^VADPT 10061 Supported
+28 ; $$SITE^VASITE 10112 Supported
+29 ; $$FMTE^XLFDT 10103 Supported
+30 ; $$CJ^XLFSTR 10104 Supported
+31 ; EN^XUTMDEVQ 1519 Supported
+32 ;
+33 ;No direct call
+34 QUIT
+35 ;
+36 ;Entry point for DG FORMER OTH PATIENTS 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,DGENCNT,SORTENCBY,DGRTNSTCK,DGPRTLRXFL
+3 NEW INACTIVE,DGDFN,DFN,VAEL,VADM,VA,I3,DGPID,DGPAGE,DGRPTSRT,DGTOTALRX,IBOTHSTAT,DGTOTRX52
+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 ;check for database
+7 IF '+$ORDER(^DGOTH(33,"B",""))
WRITE !!!,$$CJ^XLFSTR(">>> No OTH records have been found. <<<",80)
DO ASKCONT^DGOTHFSM(0)
QUIT
+8 WRITE @IOF
+9 SET (INACTIVE,DGRPTSRT,DGRTNSTCK,DGPRTLRXFL)=0
SET SORTENCBY=2
+10 WRITE "FORMER OTH PATIENT DETAIL REPORT",!!
+11 WRITE "This option assists billing user in reviewing Former Service Member's past"
+12 WRITE !,"episodes of care and released prescription details to determine if"
+13 WRITE !,"potential back-billing is necessary."
+14 WRITE !!,"*** THIS REPORT REQUIRES 132 COLUMN OUTPUT TO PRINT CORRECTLY ***"
+15 WRITE !!,"At the DEVICE: prompt, please accept the default value of '0;132;'"
+16 WRITE !,"This is to deliberately avoid undesired wrapping problems of the data.",!!
+17 ;prompt user to enter patient
+18 DO PROMPTPT
+19 if 'INACTIVE!(DGSORT'>0)
QUIT
+20 DO RECALL^DILFD(33,+DGSORT_",",DUZ)
+21 ;Prompt user what type of data/report user wish to see
+22 ;user had two options: Eligibility or Encounters
+23 IF '$$RPTTYPE
QUIT
+24 SET RECORD=$NAME(^TMP($JOB,"DGOTHFSDOS"))
+25 SET RECORD1=$NAME(^TMP($JOB,"DGOTHFSDIV"))
+26 SET IBOTHSTAT=$NAME(^TMP($JOB,"IBOTHSTAT"))
+27 ;temp data storage for all records found in file #409.68,and #405 sorted by date of service
KILL @RECORD
+28 ;temp data storage for all records found in file #409.68,and #405 sorted by division
KILL @RECORD1
+29 ;patient's RX information from File #52
KILL ^TMP($JOB,"OTHFSMR2")
+30 ;temporary storage for all Rx information and IB status ready for printing report
KILL ^TMP($JOB,"OTHFSMRX")
+31 ;temp storage for file #350 and file # 399 IB status
KILL @IBOTHSTAT
+32 ;if user select report type ALL, prompt user how it will be sorted
+33 ;do not continue, if user does not select any sorting
+34 IF DGSORT("RTYPE")="A"
Begin DoDot:1
+35 ;determine first the original date the former OTH service member become EXPANDED
+36 ;MH CARE NON-ENROLLEE and loop through all the OTH Registration Date
+37 SET DGIEN33=DGSORT
SET (DGENCNT,DGTOTALRX,DGTOTRX52,DGRTNSTCK,DGPRTLRXFL)=0
+38 ;the date when the patient became OTH
SET DGSORT("DGBEG")=$$OTHREGDT(DGIEN33)
+39 ;the date when the PE eligibility status of patient became VERIFIED
SET DGSORT("DGEND")=$$GET1^DIQ(2,DGDFN_",",.3612,"I")
+40 ;All the divisions in the facility, since we are not prompting user to enter Division
SET VAUTD=1
+41 ;check if there any past Outpatient Encounter entry (file #409.68) for this patient
DO CHKTREAT^DGFSMOUT(DGDFN,DGSORT("DGBEG"),DGSORT("DGEND"),.VAUTD,0)
+42 ;check if there any Inpatient stay entry in file #405
DO CHECKPTF^DGFSMOUT(DGDFN,DGSORT("DGBEG"),DGSORT("DGEND"),"IBOTHSTAT")
+43 ;check if this patient has records in file #350 or file #399
DO CHECKIB^DGFSMOUT("IBOTHSTAT",DGSORT("DGBEG"),DGSORT("DGEND"))
+44 ;get the medication profile of a patient from PRESCRIPTION file (#52)
DO RX^PSO52API(DGDFN,"OTHFSMR2",,,"2,R,P",DGSORT("DGBEG"),$$FMADD^XLFDT(DGSORT("DGEND"),366))
+45 ;before moving forward remove RX data from the patient's episode of care array first
+46 ;determines whether to prompt Encounter sorting
IF $ORDER(@RECORD@(""))'=""
DO FLTRENC^DGOTHFS4
+47 ;determines whether to prompt the Rx sorting and see if the Rx released date is within the date range
IF DGTOTALRX<2
SET DGTOTRX52=+$PIECE(^TMP($JOB,"OTHFSMR2",DGDFN,0),U)
IF +DGTOTRX52>0
DO TOTRX^DGOTHFS4
+48 SET DGTOTALRX=DGTOTALRX+DGTOTRX52
+49 ;extract in advance the IB STATUS in both file #350 and file #399
IF $ORDER(@IBOTHSTAT@(""))=""
DO EN^IBEFSMUT(DGDFN,DGSORT("DGBEG"),DGSORT("DGEND"),"IBOTHSTAT")
+50 IF (DGENCNT>1)
IF (DGTOTALRX>1)
Begin DoDot:2
+51 WRITE !!,"Please select sorting order for Episodes of Care and Released Prescription",!,"report section:"
+52 ;prompt user how the Encounter report section will be sorted
+53 IF '$$SORTENC^DGOTHFS3
QUIT
+54 ;prompt user Rx report section will be sorted
+55 IF '$$SORTRX^DGOTHFS3
QUIT
+56 SET DGRPTSRT=1
End DoDot:2
QUIT
+57 IF (DGENCNT>1)
IF (DGTOTALRX<2)
Begin DoDot:2
+58 WRITE !!,"Please select sorting order for Episodes of Care report section:"
+59 IF '$$SORTENC^DGOTHFS3
QUIT
+60 SET DGRPTSRT=1
SET DGSORT("SORTRXBY")=1
End DoDot:2
QUIT
+61 IF (DGENCNT<2)
IF (DGTOTALRX>1)
Begin DoDot:2
+62 WRITE !!,"Please select sorting order for Released Prescription report section:"
+63 IF '$$SORTRX^DGOTHFS3
QUIT
+64 SET DGRPTSRT=1
+65 SET DGSORT("SORTENCBY")=1
End DoDot:2
QUIT
+66 SET DGSORT("SORTENCBY")=1
SET DGSORT("SORTRXBY")=1
+67 SET DGRPTSRT=1
End DoDot:1
if DGRPTSRT<1
QUIT
+68 WRITE !!
+69 SET %ZIS=""
+70 SET %ZIS("B")="0;132;"
+71 SET ZTSAVE("DGSORT(")=""
+72 SET ZTSAVE("DGSORT")=""
+73 SET ZTSAVE("DGDFN")=""
+74 SET ZTSAVE("DGPTNM")=""
+75 SET ZTSAVE("DGTOTALRX")=""
+76 SET X="FORMER OTH PATIENT ELIGIBILITY CHANGE REPORT"
+77 DO EN^XUTMDEVQ("START^DGOTHFS2",X,.ZTSAVE,.%ZIS)
+78 DO HOME^%ZIS
+79 QUIT
+80 ;
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 SET (DGQ,DGPAGE,I3)=0
+5 SET DGIEN33=DGSORT
+6 SET DFN=DGDFN
+7 SET DGPID=$$GET1^DIQ(2,DFN_",",.0905,"I")
+8 ;display the patient's current and verified eligibility
+9 DO CURRENT(DGDFN,DGPTNM)
+10 WRITE !
+11 ;display patient's Means Test Status information
+12 DO MTS(DGDFN)
+13 ;display patient's Rated Disabilities information
+14 DO RTDDIS(DGDFN)
+15 if DGQ
QUIT
+16 ;display patient's Insurance information
+17 DO INS(DGDFN)
+18 if DGQ
QUIT
+19 ;display patient's all Primary Eligibility history
+20 DO HISTORY(DGIEN33)
+21 if DGQ
QUIT
+22 ;if user wants to see patient Encounter and Rx information
+23 IF DGSORT("RTYPE")="A"
Begin DoDot:1
+24 ;display patient's checked out Encounters and inpatient data
+25 DO ENCTR(DGDFN,.DGSORT)
+26 if DGQ
QUIT
+27 ;display patient's Released Prescriptions
+28 DO RX(DGDFN,.DGSORT)
End DoDot:1
+29 DO KVAR^VADPT
+30 KILL @RECORD,@RECORD1,@IBOTHSTAT,^TMP($JOB,"OTHFSMR2"),^TMP($JOB,"OTHFSMRX")
+31 DO EXIT^DGOTHFSM
+32 QUIT
+33 ;
PROMPTPT ;prompt user to enter patient
+1 ;keep prompting for patient name until user enter patient with INACTIVE status
+2 FOR
Begin DoDot:1
+3 ;Prompt user for OTH patient name
+4 SET DGPTNM=$$SELPAT(.DGSORT)
+5 IF DGSORT'>0
SET INACTIVE=1
QUIT
+6 IF $$ACTIVE(.DGSORT)
Begin DoDot:2
+7 WRITE !!,"The patient you selected is still PENDING for VBA Adjudication."
+8 DO RUNOPT
End DoDot:2
QUIT
+9 ;if INACTIVE STATUS, check if the eligibility status is VERIFIED
+10 SET DGDFN=$PIECE(DGSORT(0),U)
+11 IF $$GET1^DIQ(2,DGDFN_",",.3611,"I")'="V"
Begin DoDot:2
+12 WRITE !!,"The primary eligibility status of the patient you selected is not VERIFIED."
+13 DO RUNOPT
End DoDot:2
QUIT
+14 SET INACTIVE=1
End DoDot:1
if INACTIVE
QUIT
+15 QUIT
+16 ;
RUNOPT ;display message to run FORMER OTH PATIENT ELIGIBILITY CHANGE REPORT option
+1 WRITE !,"Please run FORMER OTH PATIENT ELIGIBILITY CHANGE REPORT option"
+2 WRITE !,"to identify Former OTH Service Member whose Primary Eligibility"
+3 WRITE !,"changed from EXPANDED MH CARE NON-ENROLLEE to a new Primary"
+4 WRITE !,"Eligibility with a VERIFIED eligibility status.",!
+5 QUIT
+6 ;
ACTIVE(DGSORT) ;determine the current status of OTH patient
+1 ;return 0 for INACTIVE
+2 ;otherwise, 1 for ACTIVE
+3 NEW DGIEN33,DGOTHSTAT
+4 SET DGIEN33=DGSORT
+5 SET DGOTHSTAT=$$GET1^DIQ(33,DGIEN33_",",.02,"I")
+6 QUIT DGOTHSTAT
+7 ;
SELPAT(DGSORT) ;prompt for veteran's name
+1 ;- input vars for ^DIC call
+2 NEW DIC,DTOUT,DUOUT,X,Y
+3 SET DIC="^DGOTH(33,"
SET DIC(0)="AEMQZV"
+4 SET DIC("A")="Enter Patient Name: "
+5 SET DIC("?PARAM",33,"INDEX")="B"
+6 SET DIC("?N",33)=12
+7 ;- lookup patient
+8 DO ^DIC
KILL DIC
+9 ;- result of lookup
+10 SET DGSORT=Y
+11 ;- if success, setup return array using output vars from ^DIC call
+12 ;patient name
IF (+DGSORT>0)
Begin DoDot:1
+13 ;patient ien
SET DGSORT=+Y
+14 ;zero node of patient in (#2) file
SET DGSORT(0)=$GET(Y(0))
End DoDot:1
QUIT Y(0,0)
+15 QUIT -1
+16 ;
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, Episodes of Care, Prescription)"
+6 SET DGASK=$$ANSWER^DGOTHFSM(DGDIRA,DGDIRB,DGDIRO,DGDIRH)
+7 IF DGASK="E"!(DGASK="A")
SET DGSORT("RTYPE")=DGASK
SET DGASK=1
+8 IF '$TEST
SET DGASK=0
+9 QUIT DGASK
+10 ;
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("FORMER OTH PATIENT DETAIL REPORT")
+5 DO LINE(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,DGDFN_",",.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 SET DGENRIEN=$$FINDCUR^DGENA(DFN)
+11 IF DGENRIEN'=""
SET DGENRPRI=$$GET1^DIQ(27.11,DGENRIEN_",",.07,"E")
SET DGENRGRP=$$GET1^DIQ(27.11,DGENRIEN_",",.12,"E")
+12 WRITE !,"Enrollment Priority : ",$SELECT(DGENRIEN="":"NOT ENROLLED",((DGENRPRI="")&(DGENRGRP="")):"NONE STATED",1:DGENRPRI_DGENRGRP)
+13 WRITE !
DO LINE(1)
+14 QUIT
+15 ;
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(.DGQ)
if DGQ
QUIT
DO PTHDR
DO LINE(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(.DGQ)
if DGQ
QUIT
DO PTHDR
DO LINE(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 QUIT
+11 ;
HISTORY(IEN33) ;extract all eligibility history
+1 NEW DGELHIST,DGOTHIST,DGRECNUM,DGLINE,DGOTHTYP
+2 ;display this piece of information to its own page so that the report will not look cluttered
+3 DO PAUSE(.DGQ)
if DGQ
QUIT
DO PTHDR
DO LINE(0)
WRITE !
+4 DO HDR(0)
+5 WRITE !
+6 KILL DGOTHIST
+7 SET DGELHIST=$$CROSS^DGOTHINQ(IEN33,.DGOTHIST)
+8 ;go through all the eligibility history and only display date starting from Feb. 20,2020
+9 ;3200220 is the Release Date of EXPANDED MH CARE NON-ENROLLEE
+10 SET DGRECNUM=""
FOR
SET DGRECNUM=$ORDER(DGOTHIST(IEN33,DGRECNUM))
if DGRECNUM=""
QUIT
Begin DoDot:1
+11 IF $Y>(IOSL-4)
WRITE !
DO PAUSE(.DGQ)
if DGQ
QUIT
DO PTHDR
DO LINE(0)
WRITE !!
DO HDR(1)
+12 SET DGLINE=DGOTHIST(IEN33,DGRECNUM)
+13 SET DGOTHTYP=$$OTHTYP^DGOTHINQ($PIECE(DGLINE,U))
+14 WRITE $SELECT($PIECE(DGLINE,U)="":"UNKNOWN",+DGOTHTYP:"EXPANDED MH CARE NON-ENROLLEE"_" ("_$PIECE(DGLINE,U)_")",1:$PIECE(DGLINE,U))
+15 IF $PIECE(DGLINE,U)="EXPANDED MH CARE NON-ENROLLEE"
WRITE " (N/A)"
+16 WRITE ?60,$$FMTE^XLFDT($PIECE(DGLINE,U,2),"5Z")
+17 WRITE !
End DoDot:1
if DGQ
QUIT
+18 ;break before going back to parent menu
+19 IF DGSORT("RTYPE")="E"
WRITE !!,"<< end of report >>"
DO ASKCONT^DGOTHFSM(0)
WRITE @IOF
+20 QUIT
+21 ;
OTHREGDT(DGIEN33) ;determine the original date the former OTH service member become EXPANDED MH CARE NON-ENROLLEE
+1 ;return the original OTH registration date
+2 NEW DGFOUND,DGTOTREC,DGRECNUM,DGOTHARR,DGOTHREGDT,DGERR,DGREGDT,II
+3 SET (DGFOUND,DGTOTREC,DGOTHREGDT)=0
+4 SET DGTOTREC=$PIECE(^DGOTH(33,DGIEN33,2,0),U,4)
+5 if +DGTOTREC<1
QUIT
+6 FOR II=1:1:DGTOTREC
SET DGREGDT(II)=""
+7 SET DGRECNUM=""
FOR
SET DGRECNUM=$ORDER(DGREGDT(DGRECNUM))
if DGRECNUM=""!(DGFOUND)
QUIT
Begin DoDot:1
+8 KILL DGOTHARR,DGERR
+9 DO GETS^DIQ(33,DGIEN33_",","2*","IE","DGOTHARR","DGERR")
+10 if $DATA(DGERR)
QUIT
+11 ;check if the eligibility is EXPANDED MH CARE NON-ENROLLEE
+12 IF DGOTHARR(33.02,DGRECNUM_","_DGIEN33_",",.02,"E")="EXPANDED MH CARE NON-ENROLLEE"
Begin DoDot:2
+13 ;the original OTH registration date
+14 SET DGOTHREGDT=$GET(DGOTHARR(33.02,DGRECNUM_","_DGIEN33_",",.01,"I"))
+15 SET DGFOUND=1
End DoDot:2
End DoDot:1
+16 QUIT DGOTHREGDT\1
+17 ;
ENCTR(DFN,DGSORT) ;display patient's episodes of care
+1 NEW DGDIV,DGENCTRDT,DGTOTENC,SUB1,SUB2,JJ,DGENCTRIB,FILENO,STAT350,STAT399,BILLNO,ACRTYP,CHRGCNT,PRINTRPT
+2 ;display this piece of information to its own page so that the report will not look cluttered
+3 DO PAUSE(.DGQ)
if DGQ
QUIT
DO PTHDR
DO LINE(0)
+4 DO ENCHDR(0)
DO ENCTRCOL
DO LINE(1)
+5 SET (DGTOTENC,PRINTRPT)=0
+6 IF $ORDER(@RECORD@(""))=""
Begin DoDot:1
+7 WRITE !!,">> NO DATA FOUND FROM "_$$FMTE^XLFDT(DGSORT("DGBEG"),"5ZF")_" TO "_$$FMTE^XLFDT(DGSORT("DGEND"),"5ZF")_"."
+8 WRITE !
DO LINE(1)
+9 if DGQ
QUIT
+10 WRITE !!,"Total Number of Encounter: ",DGTOTENC
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 IF 'PRINTRPT
Begin DoDot:2
+13 IF $PIECE(DGSORT("SORTENCBY"),U)=2
Begin DoDot:3
+14 KILL @RECORD
+15 MERGE @RECORD=@RECORD1
+16 KILL @RECORD1
End DoDot:3
+17 ;extract the IB status
DO ENCTRIB^DGOTHFS3
+18 SET PRINTRPT=1
End DoDot:2
+19 ;use the same loop to display status
DO ENCTRIB^DGOTHFS3
End DoDot:1
+20 QUIT
+21 ;
ENCTRCOL ;display encounter column name
+1 WRITE !,"Location of",?22,"Clinic Stop/",?45,"Primary",?55,"Div.",?61,"Date of",?72,"Last Updated",?89,"Bill #",?100,"Action Type/",?116,"IB Status"
+2 WRITE !,"Care",?22,"Treating Specialty",?45,"DX",?61,"Service",?77,"By",?100,"Rate Type",!
+3 QUIT
+4 ;
ENCHDR(FLAG) ;Encounter Header
+1 NEW TITLE
+2 SET TITLE="PATIENT'S EPISODE OF CARE"_$SELECT(FLAG:" - Continuation",1:"")
+3 WRITE !,?132-$LENGTH(TITLE)\2,TITLE,!
+4 DO DTRANGE
+5 SET TITLE="Sorted By: "_$EXTRACT($PIECE(DGSORT("SORTENCBY"),U,2),4,20)
+6 IF $PIECE(DGSORT("SORTENCBY"),U,2)'=""
WRITE ?132-$LENGTH(TITLE)\2,TITLE,!
+7 DO LINE(1)
+8 QUIT
+9 ;
DTRANGE ;display date range
+1 NEW DTRANGE
+2 SET DTRANGE="Date Range: "_$$FMTE^XLFDT(DGSORT("DGBEG"),"5ZF")_" - "_$$FMTE^XLFDT(DGSORT("DGEND"),"5ZF")
+3 WRITE ?132-$LENGTH(DTRANGE)\2,DTRANGE,!
+4 QUIT
+5 ;
RX(DFN,DGSORT) ;extract patient's released prescription
+1 NEW FILENO,OTHIBDT,OTHIBREC,ACCTYP,RESULT,CNTR,OTHIBRX
+2 ;display this piece of information to its own page so that the report will not look cluttered
+3 DO PAUSE(.DGQ)
if DGQ
QUIT
DO PTHDR
DO LINE(0)
+4 ;traverse ^TMP($J,"IBOTHSTAT" if the dates listed exist
+5 ;in the ^TMP($J,"OTHFSMR2", this is where all the RX's of the patient
+6 ;is stored.
+7 SET CNTR=0
+8 FOR FILENO=350,399
Begin DoDot:1
+9 if $PIECE(^TMP($JOB,"IBOTHSTAT",FILENO,DFN,0),U)<1
QUIT
+10 SET OTHIBDT=""
FOR
SET OTHIBDT=$ORDER(^TMP($JOB,"IBOTHSTAT",FILENO,OTHIBDT))
if OTHIBDT=""
QUIT
Begin DoDot:2
+11 SET OTHIBREC=""
FOR
SET OTHIBREC=$ORDER(^TMP($JOB,"IBOTHSTAT",FILENO,OTHIBDT,DFN,OTHIBREC))
if OTHIBREC=""
QUIT
Begin DoDot:3
+12 ;quit if not within the date range selected by the user
+13 if '$$CHKDATE(OTHIBDT,.DGSORT)
QUIT
+14 IF FILENO=350
Begin DoDot:4
+15 SET ACCTYP=$PIECE(^TMP($JOB,"IBOTHSTAT",FILENO,OTHIBDT,DFN,OTHIBREC),U)
End DoDot:4
if ACCTYP'["RX"
QUIT
+16 IF FILENO=399
Begin DoDot:4
+17 SET ACCTYP=$PIECE($PIECE($PIECE(^TMP($JOB,"IBOTHSTAT",FILENO,OTHIBDT,DFN,OTHIBREC),U,5),";"),":")
End DoDot:4
if $PIECE(ACCTYP,U)'=3
QUIT
+18 SET RESULT=$PIECE(^TMP($JOB,"IBOTHSTAT",FILENO,OTHIBDT,DFN,OTHIBREC),U,5)
+19 ;file #350 RX IEN
IF $PIECE(RESULT,":")=52
SET OTHIBRX=+$PIECE(RESULT,":",2)
+20 IF $PIECE(RESULT,":")=350
SET OTHIBRX=0
+21 ;file #399 RX IEN
IF ACCTYP=3
SET OTHIBRX=$PIECE(RESULT,":",3)
+22 DO RX1^DGOTHFS3
End DoDot:3
if DGQ
QUIT
+23 if DGQ
QUIT
End DoDot:2
if DGQ
QUIT
+24 if DGQ
QUIT
End DoDot:1
if DGQ
QUIT
+25 IF DGQ
KILL ^TMP($JOB,"OTHFSMR2"),^TMP($JOB,"OTHFSMRX")
QUIT
+26 ;Extract those RX's that has not been charge
DO RXNOSTAT^DGOTHFS3
+27 DO PRINTRX^DGOTHFS4
+28 KILL ^TMP($JOB,"OTHFSMR2"),^TMP($JOB,"OTHFSMRX")
+29 WRITE !!,"<< end of report >>"
+30 if DGQ
QUIT
+31 DO ASKCONT^DGOTHFSM(0)
WRITE @IOF
+32 QUIT
+33 ;
LINE(FLAG) ;prints double dash line
+1 NEW LINE
+2 IF FLAG<1
FOR LINE=1:1:132
WRITE "="
+3 IF '$TEST
FOR LINE=1:1:132
WRITE "-"
+4 QUIT
+5 ;
PTHDR(TITLE) ;patient name and DOB header
+1 SET TITLE=$GET(TITLE)
+2 IF $GET(TRM)!('$GET(TRM)&DGPAGE)
WRITE @IOF
+3 IF $LENGTH(TITLE)
WRITE ?132-$LENGTH(TITLE)\2,TITLE
WRITE !!
+4 SET DGPAGE=$GET(DGPAGE)+1
+5 WRITE "Patient Name: ",DGPTNM_" ("_DGPID_")",?112,"DOB: ",$PIECE(VADM(3),U,2),!
+6 QUIT
+7 ;
HDR(FLAG) ;Primary Eligibility History header
+1 NEW TITLE
+2 SET TITLE="PRIMARY ELIGIBILITY/EXPANDED CARE TYPE HISTORY"_$SELECT(FLAG:" - Continuation",1:"")
+3 WRITE ?132-$LENGTH(TITLE)\2,TITLE,!
+4 DO LINE(1)
+5 WRITE "Primary Eligibility",?60,"Date of Change",!
+6 DO LINE(1)
+7 QUIT
+8 ;
PAUSE(DGQ) ; pause screen display
+1 NEW J
+2 IF $Y<(IOSL-4)
Begin DoDot:1
+3 FOR J=1:1
if ($Y>(24-4))
QUIT
WRITE !
End DoDot:1
+4 IF $GET(DGPAGE)>0
IF TRM
IF $$E("Press <Enter> to continue or '^' to exit:")<1
SET DGQ=1
+5 QUIT
+6 ;
E(MSG) ; ----- ask user to press enter to continue
+1 ; Return: -2:Time-out; -1:'^'-out 1:anything else
+2 SET MSG=$GET(MSG)
+3 NEW X,Y,Z,DIR,DIROUT,DIRUT,DTOUT,DUOUT
+4 SET DIR(0)="EA"
+5 IF $LENGTH(MSG)
SET DIR("A")=MSG
+6 DO ^DIR
+7 SET X=$SELECT($DATA(DTOUT):-2,$DATA(DUOUT):-1,1:1)
+8 QUIT X
+9 ;
HELP ;provide extended DIR("?") help text.
+1 IF (X="?")!(X="??")
Begin DoDot:1
+2 WRITE !,"Select ""E""ligibility if you wish to see the Primary Eligibility history"
+3 WRITE !," Means Test, and Health Insurance information of the selected"
+4 WRITE !," patient.",!
+5 WRITE !,"Select ""A""ll if you wish to see the Primary Eligibility history,"
+6 WRITE !," Means Test, Health Insurance information, Patient's"
+7 WRITE !," Episodes of Care, and patient's Released Prescriptions"
+8 WRITE !," of the selected patient.",!
End DoDot:1
+9 QUIT
+10 ;
CHKDATE(DATE,DGSORT) ;check if dates fall within the Begin and End dates
+1 QUIT DGSORT("DGBEG")<=DATE&(DGSORT("DGEND")>=DATE)
+2 ;
