DGPPRRPT ;SLC/RM - PRESUMPTIVE PSYCHOSIS RECONCILIATION REPORT ; Dec 02, 2020@3:00 pm
;;5.3;Registration;**1034,1035**;Aug 13, 1993;Build 14
;
;Global References Supported by ICR# Type
;----------------- ----------------- ----------
; ^TMP($J SACC 2.3.2.5.1
;
;External References
;-------------------
; COMMA^%DTC 10000 Supported
; HOME^%ZIS 10086 Supported
; ^%ZISC 10089 Supported
; WAIT^DICD 10024 Supported
; GETS^DIQ 2056 Supported
; ^DIR 10026 Supported
; 2^VADPT 10061 Supported
; KVAR^VADPT 10061 Supported
; $$SITE^VASITE 10112 Supported
; $$FMTE^XLFDT 10103 Supported
; EN^XUTMDEVQ 1519 Supported
Q
;
;Main entry point for PRESUMPTIVE PSYCHOSIS RECONCILIATION REPORT option
MAIN ; Initial Interactive Processing
N DGSORT ;array of report parameters
N ZTDESC,ZTQUEUED,ZTREQ,ZTSAVE,ZTSTOP,%ZIS
W @IOF
W "PRESUMPTIVE PSYCHOSIS RECONCILIATION REPORT"
W !!,"This option generates a list of patients registered under Presumptive"
W !,"Psychosis authority who have had episodes of care within the user"
W !,"specified date range."
W !!,"Patients registered correctly using VA workaround and/or Presumptive"
W !,"Psychosis Category will only be displayed in this report."
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.",!
;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="PRESUMPTIVE PSYCHOSIS RECONCILIATION REPORT"
D EN^XUTMDEVQ("START^DGPPRRPT",X,.ZTSAVE,.%ZIS)
D HOME^%ZIS
Q
;
DATEFROM() ;prompt for FROM Date of Service
N DGASK,DGDIRA,DGDIRB,DGDIRH,DGDIRO,DGBEGDT,DGSTRTDT
S DGBEGDT=3130314 ;03/14/2013 - Presumptive Psychosis legislation date
S DGDIRA=" Start with Date: "
S DGDIRB=$$FMTE^XLFDT(DGBEGDT)
S DGDIRH="^D HELP^DGPPRRPT(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^DGPPRRPT(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 DGPPDT
S DGPPDT=3130314
I (X="?")!(X="??") D Q
. W !," Enter the VERIFIED Primary Eligibility status date"
. W !," of the patient."
. W ! D HELP1
. W ! D HELP2
. I $D(Y) K Y
W !," The Date you entered is not valid."
I $D(Y),Y<DGPPDT 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 MARCH 14, 2013."
W !," Date prior to 03/14/2013 is not allowed since the"
W !," Presumptive Psychosis authority was implemented on"
W !," 03/14/2013."
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 DGPPLST ;temp data storage used for report list
N RECORD ;temp data storage for all records found in file #409.68,#52,#405
N IBOTHSTAT
S DGPPLST=$NA(^TMP($J,"DGPPMUL")) ;contains all PP data to be displayed in the report
S RECORD=$NA(^TMP($J,"DGPPEOC")) ;contains all PP episodes of care data found in file #409.68,#52,#405,#45
S IBOTHSTAT=$NA(^TMP($J,"DGPPRPT1")) ;contains all PP data found in file #350, and #399
K @DGPPLST,@RECORD,@IBOTHSTAT
D LOOP(.DGSORT,DGPPLST)
D PRINTPP^DGPPRRP1(.DGSORT,DGPPLST)
K @DGPPLST,@RECORD,@IBOTHSTAT
D EXIT
Q
;
LOOP(DGSORT,DGPPLST) ;
N DGDFN,VAUTD,SORTENCBY,CPT,DGPTNAME,DGPID,DGDOB,DGENCNT,DGPPWRK,DGPPCAT,DGPPARR,DGPPERR
N VAEL,VADM,DGDOD,DATA,DGPEELG,DGELIGDATE,VA,DFN,I,I1,OTHER,DGPPFLGRPT
S SORTENCBY=0
;PP VA Workaround
; Registration Screen <7>
; - Patient Type: SC Veteran
; - Veteran : Yes
; - Service Connected: Yes
; - Service Connected %: 0%
; - Primary Elig Code: SC LESS THAN 50%
; - Other Elig Code(s): HUMANITARIAN EMERGENCY
; Registration Screen <5>
; - VHA DIRECTIVE 1029 WNR (This is a Free text for insurance buffer entry)
; Registration Screen <11>
; - Select RATED DISABILITIES (VA): 9410 (unspecified neurosis)
; - DISABILITY %: 0
; and/or with
; Registration Screen <7>
; - PP Indicator (SHRPE 1.0)
;Note: This report will not filter the facility/division of the episodes of care where the report is run
; It will display all facility/division regardless where the report is run
S VAUTD=1 ;All the divisions in the facility, since we are not prompting user to enter Division
S DGPPFLGRPT=1 ;this flag will be used to determine which mumps code to execute in DGFSMOUT routine
;Loop through all PATIENT file #2
S (DGDFN,CPT)=0 F S DGDFN=$O(^DPT(DGDFN)) Q:'DGDFN D
. S CPT=CPT+1 W:'(CPT#60000) "." ;write . every 60,000 processed records
. S DGPPWRK=$$PPWRKARN^DGPPAPI(DGDFN) ;check if this patient is registered correctly using PP VA workaround settings
. S DGPPCAT=$$PPINFO^DGPPAPI(DGDFN) ;check for PP category
. I $P(DGPPCAT,U)'="Y" S DGPPCAT="N"
. I DGPPWRK="Y"!($P(DGPPCAT,U)="Y") D ;if PP VA Workaround exist or PP Category exist, extract episode of care/inpatient/bill charges/rx
. . K @RECORD ;evaluate each patient one at a time
. . S (DGENCNT,I1,I)=0
. . ;only collect completed encounter with STATUS=CHECKED OUT
. . D CHKTREAT^DGFSMOUT(+DGDFN,DGSORT("DGBEG"),DGSORT("DGEND"),.VAUTD,0) ;check if there any past Outpatient Encounter entry in file #409.68
. . D CHECKPTF^DGFSMOUT(DGDFN,DGSORT("DGBEG"),DGSORT("DGEND"),"DGPPRPT1") ;check if there any Inpatient stay entry in file #405 OR file #45
. . D CHECKIB^DGFSMOUT("DGPPRPT1",DGSORT("DGBEG"),DGSORT("DGEND")) K ^TMP($J,"DGPPRPT1") ;check if this patient has records in file #350 or file #399
. . D CHECKRX^DGFSMOUT("DGPPRX52") ;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, 405, and file 45
. . ;if all checking above passed, then extract patient name,PID,DOB,PP Category,Date of Service,Primary Eligibility,Other Eligibility,Date of Death
. . K DATA,DGPPARR,DGPPERR D GETS^DIQ(2,DGDFN_",",".01;.0905;.361;.3611;.3612;.351","IE","DGPPARR","DGPPERR")
. . Q:$D(DGPPERR)
. . S DGPTNAME=$G(DGPPARR(2,DGDFN_",",.01,"I")) ;PP name
. . S DGPID=$G(DGPPARR(2,DGDFN_",",.0905,"I")) ;pid
. . K VAEL,VADM,DFN S DFN=DGDFN D 2^VADPT
. . S DGDOB=$P(VADM(3),U) ;date of birth
. . S DGDOD=$G(DGPPARR(2,DGDFN_",",.351,"I")) ;date of death
. . S DGPEELG=$G(DGPPARR(2,DGDFN_",",.361,"E")) ;primary eligibility
. . S DGELIGDATE=$G(DGPPARR(2,DGDFN_",",.3612,"I")) ;PE verified
. . S DATA=DGPTNAME_U_DGPID_U_DGDOB_U_DGDOD_U_$P(DGPPCAT,U,2)_U_DGPEELG_U
. . S @DGPPLST@(DGPTNAME,DGDFN)=DATA
. . K OTHER I $D(VAEL(1))>9 S I1=0 F I=0:0 S I=$O(VAEL(1,I)) Q:'I S I1=I1+1,OTHER(I1)=$P(VAEL(1,I),"^",2)
. . E S OTHER(1)="NO OTHER ELIG. IDENTIFIED",I1=1
. . D KVAR^VADPT
. . D EOC,EOC2
Q
;
EOC ;Episode of care date of service
N DGDOS,DGSTATN,FILENO,CNT,EOCIEN,IBFILENO,RESULT,EOCIEN399,EOCIEN45,RECNUM,EOCIEN405,NWBL350,TRUINPT,ARY350,RXARY52,RXIEN,OUTPATARY,OUTTRUE
S (I,EOCIEN45,EOCIEN,EOCIEN399,RECNUM,EOCIEN405,NWBL350,TRUINPT,RXIEN,OUTTRUE)=0
S DGDOS="" F S DGDOS=$O(@RECORD@(DGDOS)) Q:DGDOS="" D
. S DGSTATN="" F S DGSTATN=$O(@RECORD@(DGDOS,DGSTATN)) Q:DGSTATN="" D
. . S FILENO="" F S FILENO=$O(@RECORD@(DGDOS,DGSTATN,FILENO)) Q:FILENO="" D
. . . S CNT="" F S CNT=$O(@RECORD@(DGDOS,DGSTATN,FILENO,CNT)) Q:CNT="" D
. . . . S (RECNUM,TRUINPT,RXIEN,OUTTRUE)=0
. . . . I FILENO=350 D Q ;manually entered charges and is not linked to any file
. . . . . S RESULT=$P(@RECORD@(DGDOS\1,+DGSTATN,FILENO,CNT),U,11) ;file #350 resulting from
. . . . . I $P(RESULT,":")=44 K @RECORD@(DGDOS,DGSTATN,FILENO,CNT) Q ;we are not including any file #44 records as of the moment
. . . . . I $P(RESULT,":")=350 D
. . . . . . S NWBL350=$P($P(@RECORD@(DGDOS,DGSTATN,FILENO,CNT),U,10),"-",2) ;same date and bill number, count them as one record
. . . . . . I NWBL350="" S NWBL350=$P(@RECORD@(DGDOS,DGSTATN,FILENO,CNT),U,9) ;if BILL NO is null, get the IEN instead
. . . . . . I '$D(ARY350(DGDOS,NWBL350)) D EOC1(FILENO) S ARY350(DGDOS,NWBL350)=""
. . . . . . K @RECORD@(DGDOS,DGSTATN,FILENO,CNT)
. . . . . I $P(RESULT,":")=52 D
. . . . . . S RXIEN=$P($P($P(@RECORD@(DGDOS,DGSTATN,FILENO,CNT),U,11),":",2),";") ;file #350 RXIEN from file #52
. . . . . . I '$D(RXARY52(DGDOS,RXIEN)) D EOC1(FILENO) S RXARY52(DGDOS,RXIEN)=""
. . . . . . K @RECORD@(DGDOS,DGSTATN,FILENO,CNT)
. . . . I FILENO=52 D
. . . . . S RXIEN=$P($P(@RECORD@(DGDOS,DGSTATN,FILENO,CNT),U,7),":",2) ;file #52 RXIEN
. . . . . I '$D(RXARY52(DGDOS,RXIEN)) D EOC1(FILENO) S RXARY52(DGDOS,RXIEN)=""
. . . . . K @RECORD@(DGDOS,DGSTATN,FILENO,CNT)
. . . . I FILENO=399 D
. . . . . S RESULT=$P(@RECORD@(DGDOS,DGSTATN,FILENO,CNT),U,12),RXIEN=$P(RESULT,":",3)
. . . . . I RESULT["PRESCRIPTION",'$D(RXARY52(DGDOS,RXIEN)) D EOC1(FILENO) S RXARY52(DGDOS,RXIEN)=""
. . . . . K @RECORD@(DGDOS,DGSTATN,FILENO,CNT)
. . . . I FILENO=405!(FILENO=409.68) D
. . . . . I FILENO=409.68,$P(@RECORD@(DGDOS,DGSTATN,FILENO,CNT),U,10)'=1 D Q:OUTTRUE
. . . . . . I $D(OUTPATARY($P(@RECORD@(DGDOS,DGSTATN,FILENO,CNT),U,3),DGDOS\1)) S OUTTRUE=1 Q ;this means the record belongs to a secondary stop code, as per business owner, display and count primary and secondary stop code as one
. . . . . I FILENO=405,$P(@RECORD@(DGDOS,DGSTATN,FILENO,CNT),U,10)>1 Q
. . . . . S EOCIEN=+$P(@RECORD@(DGDOS,DGSTATN,FILENO,CNT),U,7) ;IEN in either file 409.68
. . . . . I FILENO=405,$P(@RECORD@(DGDOS,DGSTATN,FILENO,CNT),U,10)<1 D ;true inpatient care record
. . . . . . S TRUINPT=1
. . . . . . S EOCIEN405=$P($P(@RECORD@(DGDOS,DGSTATN,FILENO,CNT),U,8),";") ;IEN from file 405
. . . . . . S EOCIEN45=$P($P(@RECORD@(DGDOS,DGSTATN,FILENO,CNT),U,8),";",2) ;IEN from file 45
. . . . . F IBFILENO=350,399 D
. . . . . . I $D(@RECORD@(DGDOS\1,$S(IBFILENO=350:+DGSTATN,1:DGSTATN),IBFILENO)) D
. . . . . . . S RECNUM=+$O(@RECORD@(DGDOS\1,$S(IBFILENO=350:+DGSTATN,1:DGSTATN),IBFILENO,RECNUM))
. . . . . . . S RESULT=$P(@RECORD@(DGDOS\1,$S(IBFILENO=350:+DGSTATN,1:DGSTATN),IBFILENO,RECNUM),U,11) ;file #350 resulting from
. . . . . . . I IBFILENO=350 D
. . . . . . . . I EOCIEN=$P(RESULT,":",2) K @RECORD@(DGDOS\1,+DGSTATN,IBFILENO,RECNUM) ;from file #409.68
. . . . . . . . I $P(RESULT,":")=45,EOCIEN45=$P(RESULT,":",2) K @RECORD@(DGDOS\1,+DGSTATN,IBFILENO,RECNUM) ;from file #45
. . . . . . . . I $P(RESULT,":")=405,EOCIEN405=$P(RESULT,":",2) K @RECORD@(DGDOS\1,+DGSTATN,IBFILENO,RECNUM) ;from file #405
. . . . . . . I IBFILENO=399 D
. . . . . . . . S EOCIEN399=+$P($G(@RECORD@(DGDOS\1,DGSTATN,IBFILENO,RECNUM)),U,17) ;IEN in either file 405 or file 409.68
. . . . . . . . I EOCIEN=EOCIEN399!(EOCIEN45=EOCIEN399) K @RECORD@(DGDOS\1,DGSTATN,IBFILENO,RECNUM)
. . . . . . . . I +EOCIEN<1,EOCIEN45=EOCIEN399 K @RECORD@(DGDOS\1,DGSTATN,IBFILENO,RECNUM)
. . . . . D EOC1(FILENO)
;check if there are any left over from file #350 or file #399. These records are not linked to any record in either file #409.68, #405, or file #45
I $O(@RECORD@(""))'="" D RECORD
K ARY350,RXARY52,OUTPATARY
Q
;
EOC1(FILE) ;capture the date of service
S I=I+1
S TRUINPT=$S(+TRUINPT<1:"",1:"*")
S @DGPPLST@(DGPTNAME,DGDFN,DGDOS\1,I,"OTHER",FILE,DGSTATN)=TRUINPT_DGDOS
I FILENO=405!(FILENO=409.68) S OUTPATARY($P(@RECORD@(DGDOS,DGSTATN,FILENO,CNT),U,3),DGDOS\1)=""
Q
;
EOC2 ;capture the other eligibilities if there are any
N DGDOS,DGSTATN,FILENO,II,CNTR
I I=I1!(I>I1) D EOC3 Q ;the total number of date of service is equal or more to the number of other eligibilities that the patient have
I I<I1 D ;the other eligibilities is more than the date of service
. F CNTR=1:1:I1 D EOC4
Q
;
EOC3 ;
S DGDOS="" F S DGDOS=$O(@DGPPLST@(DGPTNAME,DGDFN,DGDOS)) Q:DGDOS="" D
. S II="" F S II=$O(@DGPPLST@(DGPTNAME,DGDFN,DGDOS,II)) Q:II="" D
. . S FILENO="" F S FILENO=$O(@DGPPLST@(DGPTNAME,DGDFN,DGDOS,II,"OTHER",FILENO)) Q:FILENO="" D
. . . S DGSTATN="" F S DGSTATN=$O(@DGPPLST@(DGPTNAME,DGDFN,DGDOS,II,"OTHER",FILENO,DGSTATN)) Q:DGSTATN="" D
. . . . I $D(OTHER(II)) S $P(@DGPPLST@(DGPTNAME,DGDFN,DGDOS\1,II,"OTHER",FILENO,DGSTATN),U,2)=OTHER(II)
Q
;
EOC4 ;
N RECNT
S RECNT=0
S DGDOS="" F S DGDOS=$O(@DGPPLST@(DGPTNAME,DGDFN,DGDOS)) Q:DGDOS="" D
. I '$D(@DGPPLST@(DGPTNAME,DGDFN,DGDOS,CNTR)),CNTR>I D Q
. . S FILENO=$O(@DGPPLST@(DGPTNAME,DGDFN,DGDOS,I,"OTHER",""))
. . Q:FILENO=""
. . S DGSTATN=$O(@DGPPLST@(DGPTNAME,DGDFN,DGDOS,I,"OTHER",FILENO,"")),RECNT=1
. . S @DGPPLST@(DGPTNAME,DGDFN,DGDOS\1,CNTR,"OTHER",FILENO,DGSTATN)=""_U_OTHER(CNTR)
. S FILENO="" F S FILENO=$O(@DGPPLST@(DGPTNAME,DGDFN,DGDOS,CNTR,"OTHER",FILENO)) Q:FILENO="" D
. . S DGSTATN="" F S DGSTATN=$O(@DGPPLST@(DGPTNAME,DGDFN,DGDOS,CNTR,"OTHER",FILENO,DGSTATN)) Q:DGSTATN="" D
. . . I $D(@DGPPLST@(DGPTNAME,DGDFN,DGDOS\1,CNTR)) S RECNT=1,$P(@DGPPLST@(DGPTNAME,DGDFN,DGDOS\1,CNTR,"OTHER",FILENO,DGSTATN),U,2)=OTHER(CNTR)
Q
;
RECORD ;display those records that are not linked to any IB charges
N DOS,DGSTATN,CNT,FILENO
F FILENO=52,350,399 D
. S DGDOS="" F S DGDOS=$O(@RECORD@(DGDOS)) Q:DGDOS="" D
. . S DGSTATN="" F S DGSTATN=$O(@RECORD@(DGDOS,DGSTATN)) Q:DGSTATN="" D
. . . S CNT="" F S CNT=$O(@RECORD@(DGDOS,DGSTATN,FILENO,CNT)) Q:CNT="" D
. . . . D EOC1(FILENO) K @RECORD@(DGDOS,DGSTATN,FILENO,CNT)
Q
;
CHKDATE(DATE,BEGDT,ENDDT) ;check if dates fall within the Begin and End dates
Q BEGDT<=DATE&(ENDDT>=DATE)
;
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
;
DOLLAR(X) ; Function to return a formatted dollar amount.
I $G(X)="" Q ""
N X2,X3
S X2="2$",X3=0
D COMMA^%DTC
Q X
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPPRRPT 15574 printed Dec 13, 2024@02:50:58 Page 2
DGPPRRPT ;SLC/RM - PRESUMPTIVE PSYCHOSIS RECONCILIATION REPORT ; Dec 02, 2020@3:00 pm
+1 ;;5.3;Registration;**1034,1035**;Aug 13, 1993;Build 14
+2 ;
+3 ;Global References Supported by ICR# Type
+4 ;----------------- ----------------- ----------
+5 ; ^TMP($J SACC 2.3.2.5.1
+6 ;
+7 ;External References
+8 ;-------------------
+9 ; COMMA^%DTC 10000 Supported
+10 ; HOME^%ZIS 10086 Supported
+11 ; ^%ZISC 10089 Supported
+12 ; WAIT^DICD 10024 Supported
+13 ; GETS^DIQ 2056 Supported
+14 ; ^DIR 10026 Supported
+15 ; 2^VADPT 10061 Supported
+16 ; KVAR^VADPT 10061 Supported
+17 ; $$SITE^VASITE 10112 Supported
+18 ; $$FMTE^XLFDT 10103 Supported
+19 ; EN^XUTMDEVQ 1519 Supported
+20 QUIT
+21 ;
+22 ;Main entry point for PRESUMPTIVE PSYCHOSIS RECONCILIATION REPORT option
MAIN ; Initial Interactive Processing
+1 ;array of report parameters
NEW DGSORT
+2 NEW ZTDESC,ZTQUEUED,ZTREQ,ZTSAVE,ZTSTOP,%ZIS
+3 WRITE @IOF
+4 WRITE "PRESUMPTIVE PSYCHOSIS RECONCILIATION REPORT"
+5 WRITE !!,"This option generates a list of patients registered under Presumptive"
+6 WRITE !,"Psychosis authority who have had episodes of care within the user"
+7 WRITE !,"specified date range."
+8 WRITE !!,"Patients registered correctly using VA workaround and/or Presumptive"
+9 WRITE !,"Psychosis Category will only be displayed in this report."
+10 WRITE !!,"*** THIS REPORT REQUIRES 132 COLUMN margin width ***"
+11 WRITE !!,"At the DEVICE: prompt, please accept the default value of '0;132;99999'"
+12 WRITE !,"to avoid wrapping of data."
+13 WRITE !!,"To include pagination, please use ';132;' for the device value.",!
+14 ;Prompt user for FROM Date of Eligibility Change
+15 IF '$$DATEFROM
QUIT
+16 ;Prompt user for TO Date of Eligibility Change
+17 IF '$$DATETO
QUIT
+18 ;prompt for device
+19 WRITE !
+20 SET %ZIS=""
+21 SET %ZIS("B")="0;132;99999"
+22 SET ZTSAVE("DGSORT(")=""
+23 SET X="PRESUMPTIVE PSYCHOSIS RECONCILIATION REPORT"
+24 DO EN^XUTMDEVQ("START^DGPPRRPT",X,.ZTSAVE,.%ZIS)
+25 DO HOME^%ZIS
+26 QUIT
+27 ;
DATEFROM() ;prompt for FROM Date of Service
+1 NEW DGASK,DGDIRA,DGDIRB,DGDIRH,DGDIRO,DGBEGDT,DGSTRTDT
+2 ;03/14/2013 - Presumptive Psychosis legislation date
SET DGBEGDT=3130314
+3 SET DGDIRA=" Start with Date: "
+4 SET DGDIRB=$$FMTE^XLFDT(DGBEGDT)
+5 SET DGDIRH="^D HELP^DGPPRRPT(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^DGPPRRPT(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 ;
+4 NEW DGPPDT
+5 SET DGPPDT=3130314
+6 IF (X="?")!(X="??")
Begin DoDot:1
+7 WRITE !," Enter the VERIFIED Primary Eligibility status date"
+8 WRITE !," of the patient."
+9 WRITE !
DO HELP1
+10 WRITE !
DO HELP2
+11 IF $DATA(Y)
KILL Y
End DoDot:1
QUIT
+12 WRITE !," The Date you entered is not valid."
+13 IF $DATA(Y)
IF Y<DGPPDT
DO HELP1
IF $DATA(Y)
KILL Y
QUIT
+14 IF $DATA(Y)
IF Y>DT
DO HELP2
IF $DATA(Y)
KILL Y
QUIT
+15 QUIT
+16 ;
HELP1 ;
+1 WRITE !," The earliest date that you can enter is MARCH 14, 2013."
+2 WRITE !," Date prior to 03/14/2013 is not allowed since the"
+3 WRITE !," Presumptive Psychosis authority was implemented on"
+4 WRITE !," 03/14/2013."
+5 QUIT
+6 ;
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 DGPPLST
+5 ;temp data storage for all records found in file #409.68,#52,#405
NEW RECORD
+6 NEW IBOTHSTAT
+7 ;contains all PP data to be displayed in the report
SET DGPPLST=$NAME(^TMP($JOB,"DGPPMUL"))
+8 ;contains all PP episodes of care data found in file #409.68,#52,#405,#45
SET RECORD=$NAME(^TMP($JOB,"DGPPEOC"))
+9 ;contains all PP data found in file #350, and #399
SET IBOTHSTAT=$NAME(^TMP($JOB,"DGPPRPT1"))
+10 KILL @DGPPLST,@RECORD,@IBOTHSTAT
+11 DO LOOP(.DGSORT,DGPPLST)
+12 DO PRINTPP^DGPPRRP1(.DGSORT,DGPPLST)
+13 KILL @DGPPLST,@RECORD,@IBOTHSTAT
+14 DO EXIT
+15 QUIT
+16 ;
LOOP(DGSORT,DGPPLST) ;
+1 NEW DGDFN,VAUTD,SORTENCBY,CPT,DGPTNAME,DGPID,DGDOB,DGENCNT,DGPPWRK,DGPPCAT,DGPPARR,DGPPERR
+2 NEW VAEL,VADM,DGDOD,DATA,DGPEELG,DGELIGDATE,VA,DFN,I,I1,OTHER,DGPPFLGRPT
+3 SET SORTENCBY=0
+4 ;PP VA Workaround
+5 ; Registration Screen <7>
+6 ; - Patient Type: SC Veteran
+7 ; - Veteran : Yes
+8 ; - Service Connected: Yes
+9 ; - Service Connected %: 0%
+10 ; - Primary Elig Code: SC LESS THAN 50%
+11 ; - Other Elig Code(s): HUMANITARIAN EMERGENCY
+12 ; Registration Screen <5>
+13 ; - VHA DIRECTIVE 1029 WNR (This is a Free text for insurance buffer entry)
+14 ; Registration Screen <11>
+15 ; - Select RATED DISABILITIES (VA): 9410 (unspecified neurosis)
+16 ; - DISABILITY %: 0
+17 ; and/or with
+18 ; Registration Screen <7>
+19 ; - PP Indicator (SHRPE 1.0)
+20 ;Note: This report will not filter the facility/division of the episodes of care where the report is run
+21 ; It will display all facility/division regardless where the report is run
+22 ;All the divisions in the facility, since we are not prompting user to enter Division
SET VAUTD=1
+23 ;this flag will be used to determine which mumps code to execute in DGFSMOUT routine
SET DGPPFLGRPT=1
+24 ;Loop through all PATIENT file #2
+25 SET (DGDFN,CPT)=0
FOR
SET DGDFN=$ORDER(^DPT(DGDFN))
if 'DGDFN
QUIT
Begin DoDot:1
+26 ;write . every 60,000 processed records
SET CPT=CPT+1
if '(CPT#60000)
WRITE "."
+27 ;check if this patient is registered correctly using PP VA workaround settings
SET DGPPWRK=$$PPWRKARN^DGPPAPI(DGDFN)
+28 ;check for PP category
SET DGPPCAT=$$PPINFO^DGPPAPI(DGDFN)
+29 IF $PIECE(DGPPCAT,U)'="Y"
SET DGPPCAT="N"
+30 ;if PP VA Workaround exist or PP Category exist, extract episode of care/inpatient/bill charges/rx
IF DGPPWRK="Y"!($PIECE(DGPPCAT,U)="Y")
Begin DoDot:2
+31 ;evaluate each patient one at a time
KILL @RECORD
+32 SET (DGENCNT,I1,I)=0
+33 ;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,DGSORT("DGBEG"),DGSORT("DGEND"),.VAUTD,0)
+35 ;check if there any Inpatient stay entry in file #405 OR file #45
DO CHECKPTF^DGFSMOUT(DGDFN,DGSORT("DGBEG"),DGSORT("DGEND"),"DGPPRPT1")
+36 ;check if this patient has records in file #350 or file #399
DO CHECKIB^DGFSMOUT("DGPPRPT1",DGSORT("DGBEG"),DGSORT("DGEND"))
KILL ^TMP($JOB,"DGPPRPT1")
+37 ;check at file #52 if this patient has any RX not yet charged
DO CHECKRX^DGFSMOUT("DGPPRX52")
+38 ;do not include patient that has no record in any of these files: 409.68, 350, 399, 52, 405, and file 45
IF $ORDER(@RECORD@(""))=""
IF DGENCNT<1
QUIT
+39 ;if all checking above passed, then extract patient name,PID,DOB,PP Category,Date of Service,Primary Eligibility,Other Eligibility,Date of Death
+40 KILL DATA,DGPPARR,DGPPERR
DO GETS^DIQ(2,DGDFN_",",".01;.0905;.361;.3611;.3612;.351","IE","DGPPARR","DGPPERR")
+41 if $DATA(DGPPERR)
QUIT
+42 ;PP name
SET DGPTNAME=$GET(DGPPARR(2,DGDFN_",",.01,"I"))
+43 ;pid
SET DGPID=$GET(DGPPARR(2,DGDFN_",",.0905,"I"))
+44 KILL VAEL,VADM,DFN
SET DFN=DGDFN
DO 2^VADPT
+45 ;date of birth
SET DGDOB=$PIECE(VADM(3),U)
+46 ;date of death
SET DGDOD=$GET(DGPPARR(2,DGDFN_",",.351,"I"))
+47 ;primary eligibility
SET DGPEELG=$GET(DGPPARR(2,DGDFN_",",.361,"E"))
+48 ;PE verified
SET DGELIGDATE=$GET(DGPPARR(2,DGDFN_",",.3612,"I"))
+49 SET DATA=DGPTNAME_U_DGPID_U_DGDOB_U_DGDOD_U_$PIECE(DGPPCAT,U,2)_U_DGPEELG_U
+50 SET @DGPPLST@(DGPTNAME,DGDFN)=DATA
+51 KILL OTHER
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
SET OTHER(I1)=$PIECE(VAEL(1,I),"^",2)
+52 IF '$TEST
SET OTHER(1)="NO OTHER ELIG. IDENTIFIED"
SET I1=1
+53 DO KVAR^VADPT
+54 DO EOC
DO EOC2
End DoDot:2
End DoDot:1
+55 QUIT
+56 ;
EOC ;Episode of care date of service
+1 NEW DGDOS,DGSTATN,FILENO,CNT,EOCIEN,IBFILENO,RESULT,EOCIEN399,EOCIEN45,RECNUM,EOCIEN405,NWBL350,TRUINPT,ARY350,RXARY52,RXIEN,OUTPATARY,OUTTRUE
+2 SET (I,EOCIEN45,EOCIEN,EOCIEN399,RECNUM,EOCIEN405,NWBL350,TRUINPT,RXIEN,OUTTRUE)=0
+3 SET DGDOS=""
FOR
SET DGDOS=$ORDER(@RECORD@(DGDOS))
if DGDOS=""
QUIT
Begin DoDot:1
+4 SET DGSTATN=""
FOR
SET DGSTATN=$ORDER(@RECORD@(DGDOS,DGSTATN))
if DGSTATN=""
QUIT
Begin DoDot:2
+5 SET FILENO=""
FOR
SET FILENO=$ORDER(@RECORD@(DGDOS,DGSTATN,FILENO))
if FILENO=""
QUIT
Begin DoDot:3
+6 SET CNT=""
FOR
SET CNT=$ORDER(@RECORD@(DGDOS,DGSTATN,FILENO,CNT))
if CNT=""
QUIT
Begin DoDot:4
+7 SET (RECNUM,TRUINPT,RXIEN,OUTTRUE)=0
+8 ;manually entered charges and is not linked to any file
IF FILENO=350
Begin DoDot:5
+9 ;file #350 resulting from
SET RESULT=$PIECE(@RECORD@(DGDOS\1,+DGSTATN,FILENO,CNT),U,11)
+10 ;we are not including any file #44 records as of the moment
IF $PIECE(RESULT,":")=44
KILL @RECORD@(DGDOS,DGSTATN,FILENO,CNT)
QUIT
+11 IF $PIECE(RESULT,":")=350
Begin DoDot:6
+12 ;same date and bill number, count them as one record
SET NWBL350=$PIECE($PIECE(@RECORD@(DGDOS,DGSTATN,FILENO,CNT),U,10),"-",2)
+13 ;if BILL NO is null, get the IEN instead
IF NWBL350=""
SET NWBL350=$PIECE(@RECORD@(DGDOS,DGSTATN,FILENO,CNT),U,9)
+14 IF '$DATA(ARY350(DGDOS,NWBL350))
DO EOC1(FILENO)
SET ARY350(DGDOS,NWBL350)=""
+15 KILL @RECORD@(DGDOS,DGSTATN,FILENO,CNT)
End DoDot:6
+16 IF $PIECE(RESULT,":")=52
Begin DoDot:6
+17 ;file #350 RXIEN from file #52
SET RXIEN=$PIECE($PIECE($PIECE(@RECORD@(DGDOS,DGSTATN,FILENO,CNT),U,11),":",2),";")
+18 IF '$DATA(RXARY52(DGDOS,RXIEN))
DO EOC1(FILENO)
SET RXARY52(DGDOS,RXIEN)=""
+19 KILL @RECORD@(DGDOS,DGSTATN,FILENO,CNT)
End DoDot:6
End DoDot:5
QUIT
+20 IF FILENO=52
Begin DoDot:5
+21 ;file #52 RXIEN
SET RXIEN=$PIECE($PIECE(@RECORD@(DGDOS,DGSTATN,FILENO,CNT),U,7),":",2)
+22 IF '$DATA(RXARY52(DGDOS,RXIEN))
DO EOC1(FILENO)
SET RXARY52(DGDOS,RXIEN)=""
+23 KILL @RECORD@(DGDOS,DGSTATN,FILENO,CNT)
End DoDot:5
+24 IF FILENO=399
Begin DoDot:5
+25 SET RESULT=$PIECE(@RECORD@(DGDOS,DGSTATN,FILENO,CNT),U,12)
SET RXIEN=$PIECE(RESULT,":",3)
+26 IF RESULT["PRESCRIPTION"
IF '$DATA(RXARY52(DGDOS,RXIEN))
DO EOC1(FILENO)
SET RXARY52(DGDOS,RXIEN)=""
+27 KILL @RECORD@(DGDOS,DGSTATN,FILENO,CNT)
End DoDot:5
+28 IF FILENO=405!(FILENO=409.68)
Begin DoDot:5
+29 IF FILENO=409.68
IF $PIECE(@RECORD@(DGDOS,DGSTATN,FILENO,CNT),U,10)'=1
Begin DoDot:6
+30 ;this means the record belongs to a secondary stop code, as per business owner, display and count primary and secondary stop code as one
IF $DATA(OUTPATARY($PIECE(@RECORD@(DGDOS,DGSTATN,FILENO,CNT),U,3),DGDOS\1))
SET OUTTRUE=1
QUIT
End DoDot:6
if OUTTRUE
QUIT
+31 IF FILENO=405
IF $PIECE(@RECORD@(DGDOS,DGSTATN,FILENO,CNT),U,10)>1
QUIT
+32 ;IEN in either file 409.68
SET EOCIEN=+$PIECE(@RECORD@(DGDOS,DGSTATN,FILENO,CNT),U,7)
+33 ;true inpatient care record
IF FILENO=405
IF $PIECE(@RECORD@(DGDOS,DGSTATN,FILENO,CNT),U,10)<1
Begin DoDot:6
+34 SET TRUINPT=1
+35 ;IEN from file 405
SET EOCIEN405=$PIECE($PIECE(@RECORD@(DGDOS,DGSTATN,FILENO,CNT),U,8),";")
+36 ;IEN from file 45
SET EOCIEN45=$PIECE($PIECE(@RECORD@(DGDOS,DGSTATN,FILENO,CNT),U,8),";",2)
End DoDot:6
+37 FOR IBFILENO=350,399
Begin DoDot:6
+38 IF $DATA(@RECORD@(DGDOS\1,$SELECT(IBFILENO=350:+DGSTATN,1:DGSTATN),IBFILENO))
Begin DoDot:7
+39 SET RECNUM=+$ORDER(@RECORD@(DGDOS\1,$SELECT(IBFILENO=350:+DGSTATN,1:DGSTATN),IBFILENO,RECNUM))
+40 ;file #350 resulting from
SET RESULT=$PIECE(@RECORD@(DGDOS\1,$SELECT(IBFILENO=350:+DGSTATN,1:DGSTATN),IBFILENO,RECNUM),U,11)
+41 IF IBFILENO=350
Begin DoDot:8
+42 ;from file #409.68
IF EOCIEN=$PIECE(RESULT,":",2)
KILL @RECORD@(DGDOS\1,+DGSTATN,IBFILENO,RECNUM)
+43 ;from file #45
IF $PIECE(RESULT,":")=45
IF EOCIEN45=$PIECE(RESULT,":",2)
KILL @RECORD@(DGDOS\1,+DGSTATN,IBFILENO,RECNUM)
+44 ;from file #405
IF $PIECE(RESULT,":")=405
IF EOCIEN405=$PIECE(RESULT,":",2)
KILL @RECORD@(DGDOS\1,+DGSTATN,IBFILENO,RECNUM)
End DoDot:8
+45 IF IBFILENO=399
Begin DoDot:8
+46 ;IEN in either file 405 or file 409.68
SET EOCIEN399=+$PIECE($GET(@RECORD@(DGDOS\1,DGSTATN,IBFILENO,RECNUM)),U,17)
+47 IF EOCIEN=EOCIEN399!(EOCIEN45=EOCIEN399)
KILL @RECORD@(DGDOS\1,DGSTATN,IBFILENO,RECNUM)
+48 IF +EOCIEN<1
IF EOCIEN45=EOCIEN399
KILL @RECORD@(DGDOS\1,DGSTATN,IBFILENO,RECNUM)
End DoDot:8
End DoDot:7
End DoDot:6
+49 DO EOC1(FILENO)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+50 ;check if there are any left over from file #350 or file #399. These records are not linked to any record in either file #409.68, #405, or file #45
+51 IF $ORDER(@RECORD@(""))'=""
DO RECORD
+52 KILL ARY350,RXARY52,OUTPATARY
+53 QUIT
+54 ;
EOC1(FILE) ;capture the date of service
+1 SET I=I+1
+2 SET TRUINPT=$SELECT(+TRUINPT<1:"",1:"*")
+3 SET @DGPPLST@(DGPTNAME,DGDFN,DGDOS\1,I,"OTHER",FILE,DGSTATN)=TRUINPT_DGDOS
+4 IF FILENO=405!(FILENO=409.68)
SET OUTPATARY($PIECE(@RECORD@(DGDOS,DGSTATN,FILENO,CNT),U,3),DGDOS\1)=""
+5 QUIT
+6 ;
EOC2 ;capture the other eligibilities if there are any
+1 NEW DGDOS,DGSTATN,FILENO,II,CNTR
+2 ;the total number of date of service is equal or more to the number of other eligibilities that the patient have
IF I=I1!(I>I1)
DO EOC3
QUIT
+3 ;the other eligibilities is more than the date of service
IF I<I1
Begin DoDot:1
+4 FOR CNTR=1:1:I1
DO EOC4
End DoDot:1
+5 QUIT
+6 ;
EOC3 ;
+1 SET DGDOS=""
FOR
SET DGDOS=$ORDER(@DGPPLST@(DGPTNAME,DGDFN,DGDOS))
if DGDOS=""
QUIT
Begin DoDot:1
+2 SET II=""
FOR
SET II=$ORDER(@DGPPLST@(DGPTNAME,DGDFN,DGDOS,II))
if II=""
QUIT
Begin DoDot:2
+3 SET FILENO=""
FOR
SET FILENO=$ORDER(@DGPPLST@(DGPTNAME,DGDFN,DGDOS,II,"OTHER",FILENO))
if FILENO=""
QUIT
Begin DoDot:3
+4 SET DGSTATN=""
FOR
SET DGSTATN=$ORDER(@DGPPLST@(DGPTNAME,DGDFN,DGDOS,II,"OTHER",FILENO,DGSTATN))
if DGSTATN=""
QUIT
Begin DoDot:4
+5 IF $DATA(OTHER(II))
SET $PIECE(@DGPPLST@(DGPTNAME,DGDFN,DGDOS\1,II,"OTHER",FILENO,DGSTATN),U,2)=OTHER(II)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
EOC4 ;
+1 NEW RECNT
+2 SET RECNT=0
+3 SET DGDOS=""
FOR
SET DGDOS=$ORDER(@DGPPLST@(DGPTNAME,DGDFN,DGDOS))
if DGDOS=""
QUIT
Begin DoDot:1
+4 IF '$DATA(@DGPPLST@(DGPTNAME,DGDFN,DGDOS,CNTR))
IF CNTR>I
Begin DoDot:2
+5 SET FILENO=$ORDER(@DGPPLST@(DGPTNAME,DGDFN,DGDOS,I,"OTHER",""))
+6 if FILENO=""
QUIT
+7 SET DGSTATN=$ORDER(@DGPPLST@(DGPTNAME,DGDFN,DGDOS,I,"OTHER",FILENO,""))
SET RECNT=1
+8 SET @DGPPLST@(DGPTNAME,DGDFN,DGDOS\1,CNTR,"OTHER",FILENO,DGSTATN)=""_U_OTHER(CNTR)
End DoDot:2
QUIT
+9 SET FILENO=""
FOR
SET FILENO=$ORDER(@DGPPLST@(DGPTNAME,DGDFN,DGDOS,CNTR,"OTHER",FILENO))
if FILENO=""
QUIT
Begin DoDot:2
+10 SET DGSTATN=""
FOR
SET DGSTATN=$ORDER(@DGPPLST@(DGPTNAME,DGDFN,DGDOS,CNTR,"OTHER",FILENO,DGSTATN))
if DGSTATN=""
QUIT
Begin DoDot:3
+11 IF $DATA(@DGPPLST@(DGPTNAME,DGDFN,DGDOS\1,CNTR))
SET RECNT=1
SET $PIECE(@DGPPLST@(DGPTNAME,DGDFN,DGDOS\1,CNTR,"OTHER",FILENO,DGSTATN),U,2)=OTHER(CNTR)
End DoDot:3
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
RECORD ;display those records that are not linked to any IB charges
+1 NEW DOS,DGSTATN,CNT,FILENO
+2 FOR FILENO=52,350,399
Begin DoDot:1
+3 SET DGDOS=""
FOR
SET DGDOS=$ORDER(@RECORD@(DGDOS))
if DGDOS=""
QUIT
Begin DoDot:2
+4 SET DGSTATN=""
FOR
SET DGSTATN=$ORDER(@RECORD@(DGDOS,DGSTATN))
if DGSTATN=""
QUIT
Begin DoDot:3
+5 SET CNT=""
FOR
SET CNT=$ORDER(@RECORD@(DGDOS,DGSTATN,FILENO,CNT))
if CNT=""
QUIT
Begin DoDot:4
+6 DO EOC1(FILENO)
KILL @RECORD@(DGDOS,DGSTATN,FILENO,CNT)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+7 QUIT
+8 ;
CHKDATE(DATE,BEGDT,ENDDT) ;check if dates fall within the Begin and End dates
+1 QUIT BEGDT<=DATE&(ENDDT>=DATE)
+2 ;
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 ;
DOLLAR(X) ; Function to return a formatted dollar amount.
+1 IF $GET(X)=""
QUIT ""
+2 NEW X2,X3
+3 SET X2="2$"
SET X3=0
+4 DO COMMA^%DTC
+5 QUIT X
+6 ;
