- 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 Feb 19, 2025@00:17 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 ;