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

DGOTHRP2.m

Go to the documentation of this file. 
  1. DGOTHRP2 ;SLC/RM - OTH PATIENT PERIOD STATUS REPORT CONT. ;MAY 8, 2018@5:15
  1.  ;;5.3;Registration;**952,977**;Aug 13, 1993;Build 177
  1.  ;;Per VA Directive 6402, this routine should not be modified
  1.  ;
  1.  ;     Last Edited: SHRPE/RM - MAY 8, 2018 17:15
  1.  ;
  1.  ; ICR#   TYPE       DESCRIPTION
  1.  ;-----   ----       -------------------------------
  1.  ; 10103  Sup        ^XLFDT - [$$FMTE^XLFDT, $$NOW^XLFDT]
  1.  ; 10015  Sup        ^DIQ
  1.  ; 10086  Sup        HOME^%ZIS
  1.  ; 10063  Sup        ^%ZTLOAD
  1.  ;  1519  Sup        EN^XUTMDEVQ
  1.  ; 10089  Sup        ^%ZISC
  1.  ; 10026  Sup        ^DIR
  1.  ; 10112  Sup        $$SITE^VASITE
  1.  ; 10024  Sup        WAIT^DICD
  1.  ;   664  Cont. Sub  DIVISION^VAUTOMA
  1.  ;   417  Cont. Sub  DG has approval for direct global read of File #40.8
  1.  ;  3546  Cont. Sub  DG has approval for direct global read of "AD" index of FILE #40.8
  1.  ;   402  Cont. Sub  DG has approval for direct global read of "ADFN" index of FILE #409.68 ;
  1.  ;This routine will be used to display or print Other Than Honorable
  1.  ;Active 90-Day Period Status
  1.  ;Expired 90-Day Period Status
  1.  ;Both (Active and Expired) 90-Day Period Status
  1.  ;
  1.  ; INPUT:  DGSORT() - see comments at the top of routine DGOTHRPT for
  1.  ;         explanation of DGSORT array
  1.  ;
  1.  ; Output:  A formatted report of Other Than Honorable
  1.  ;          Active 90-Day Period Status
  1.  ;
  1.  ;- no direct entry
  1.  Q
  1.  ;
  1. START ; compile and print report
  1.  I $E(IOST)="C" D WAIT^DICD
  1.  N HERE S HERE=$$SITE^VASITE ;extract the IEN and facility name
  1.  N TRM S TRM=($E(IOST)="C")
  1.  N DGLIST ;temp global name used for report list
  1.  S DGLIST=$NA(^TMP("DGOTHR2",$J))
  1.  K @DGLIST
  1.  D LOOP(.DGSORT,DGLIST)
  1.  D PRINT(.DGSORT,DGLIST)
  1.  K @DGLIST
  1.  D EXIT
  1.  Q
  1.  ;
  1. LOOP(DGSORT,DGLIST) ;
  1.  N DGDFN,DGDIEN,DGQ,DGRES,DGIEN,DGOLD,DGTOTAL,DGARR,DGRET,DGCLCK,DG90A,DGERR,RET
  1.  ;loop variable pointer flag x-ref file to run report
  1.  S (DGDFN,DGIEN,DGOLD)="",(DGTOTAL,DGQ)=0
  1.  F  S DGDFN=$O(^DGOTH(33,"B",DGDFN)) Q:DGDFN=""  D
  1.  . N DGIEN33,DFN,DGPTSTAT,DGLS365D,DGLS365I
  1.  . K DGARR,DGRET,DGCLCK,DG90A,DGERR,RET
  1.  . ;Patient's primary eligibility code is no longer EXPANDED MH CARE NON-ENROLLEE
  1.  . Q:$$ISOTHD^DGOTHD(DGDFN)=0 
  1.  . ;Patient's current MH CARE TYPE is no longer OTH-90
  1.  . Q:'$$ISOTH90(DGDFN)
  1.  . S DGIEN33=+$O(^DGOTH(33,"B",DGDFN,0))
  1.  . D GETS^DIQ(33,DGIEN33_",",".01;.02;1*;2*","IE","DGARR","DGERR")
  1.  . Q:$D(DGERR)
  1.  . I DGARR(33,DGIEN33_",",.02,"I")<1 Q
  1.  . D CLOCK(DGIEN33)
  1.  . Q:'$D(DGCLCK)
  1.  . I $$MSNGPRD^DGOTHBTN(DGLS365D,.DGCLCK) Q
  1.  . D RESULT^DGOTHRP3(.DGARR,.DG90A,DGIEN33)
  1.  . Q:'$D(DGRET)
  1.  . S DFN=$G(DGARR(33,DGIEN33_",",.01,"I"))
  1.  . I $D(DGSORT("DGSTATUS")) D ALL90(.DGSORT,DGLIST,.DGRET,DFN,DGIEN33,.DGARR,.DG90A)
  1.  Q
  1.  ;
  1. ISOTH90(DGDFN) ;determine if patient is EMERGENT OTH
  1.  N DGEXP
  1.  S DGEXP=$$GETEXPR^DGOTHD(DGDFN)
  1.  I DGEXP="" Q 0
  1.  I DGEXP<0 Q 0
  1.  I DGEXP'?1"OTH".E Q 0
  1.  I $$ISOTH^DGOTHD(DGEXP)>1 Q 1
  1.  Q 0
  1.  ;
  1. CLOCK(DGIEN33) ;
  1.  N DGN
  1.  S DGLS365D=+$O(^DGOTH(33,DGIEN33,1,"B",999),-1)
  1.  S DGLS365I=+$O(^DGOTH(33,DGIEN33,1,"B",DGLS365D,0))
  1.  F I=1:1:DGLS365D D
  1.  . S DGN=0 F  S DGN=+$O(^DGOTH(33,DGIEN33,1,I,1,"B",DGN)) Q:DGN=0  D
  1.  . . S DG90A(DGN)=+$O(^DGOTH(33,DGIEN33,1,I,1,"B",DGN,0))
  1.  . . S DGCLCK(I)=$G(DGCLCK(I))+1,DGCLCK(I,$G(DGCLCK(I)))=DGN ;+$O(^DGOTH(33,DGIEN33,1,I,1,"B",DGN,0))
  1.  Q
  1.  ;
  1. ALL90(DGSORT,DGLIST,DGRET,DFN,DGIEN33,DGARR,DG90A) ;
  1.  N DGPTNM,DGSSN,DGAUTH,DGIENS,I,II,DGTMP,DG90,DGSDT,DGEDT,DGDYSLFT,DGENCTR
  1.  F I=1:1:DGLS365D D
  1.  . S DG90="" F  S DG90=$O(DGRET(I,DG90)) Q:DG90=""  D
  1.  . . K DGPTNM,DGSSN,DGAUTH,DGIENS,DGSDT,DGEDT,DGDYSLFT
  1.  . . S DGSDT=$P(DGRET(I,DG90),U)
  1.  . . S DGEDT=$P(DGRET(I,DG90),U,2)
  1.  . . S DGDYSLFT=$P(DGRET(I,DG90),U,3)
  1.  . . I 1[$P(DGSORT("DGSTATUS"),U),DGDYSLFT<1 Q
  1.  . . ;if user select EXPIRED 90-DAY PERIOD,check if the entire
  1.  . . ;365-day period of that patient is expired,if true,include them in the report
  1.  . . ;otherwise, skip those patients
  1.  . . I 2[$P(DGSORT("DGSTATUS"),U),DGRET(I)>0 Q
  1.  . . I 2[$P(DGSORT("DGSTATUS"),U),DGRET(I)<1,$D(DGRET(I+1)) Q
  1.  . . I $$CHKDATE(DGSDT,DGEDT) D
  1.  . . . K DGENCTR
  1.  . . . ;check if there any Outpatient Encounter entry for this patient
  1.  . . . D CHKTREAT^DGPPRP1(.DGENCTR,+DFN,DGSORT("DGBEG"),DGSORT("DGEND"),.VAUTD) Q:'$D(DGENCTR)
  1.  . . . S DGPTNM=DGARR(33,DGIEN33_",",.01,"E")
  1.  . . . S DGSSN=$$SSN(DFN)
  1.  . . . S DGIENS=DGCLCK(I,DG90)_","_I_","_+DGIEN33_","
  1.  . . . S DGAUTH=$S($G(DGARR(33.11,DGIENS,.07,"E"))="":"N/A",1:$G(DGARR(33.11,DGIENS,.07,"E")))
  1.  . . . S DGTMP=DG90_U_DGSSN_U_$$FMTE^XLFDT(DGSDT,"5Z")_U_$$FMTE^XLFDT(DGEDT,"5Z")_U_DGDYSLFT_U_DGAUTH_U_I
  1.  . . . D SORT(DGTMP,DGPTNM,DG90,DGDYSLFT,I,.DGENCTR)
  1.  Q
  1.  ;
  1. SSN(DFN) ;extract patient's SSN4
  1.  D GETS^DIQ(2,DFN_",",.0905,"ER","DGSSN")
  1.  Q DGSSN(2,DFN_",","1U4N","E")
  1.  ;
  1. SORT(DGTMP,DGPTNM,DGCLCK,DGDYSLFT,I,DGENCTR) ;
  1.  N DGDIV,DGSDT,DGDIVNUM
  1.  S (DGDIV,DGSDT)=""
  1.  F  S DGDIV=$O(DGENCTR(DGDIV)) Q:DGDIV=""  D
  1.  . F  S DGSDT=$O(DGENCTR(DGDIV,DGSDT)) Q:DGSDT=""  D
  1.  . . K DGDIVNUM
  1.  . . S DGDIVNUM=$P(DGENCTR(DGDIV,DGSDT),U,2)
  1.  . . I DGDIVNUM="" S DGDIVNUM=$S($P(^DG(40.8,DGDIV,0),U,2)="":"UNKNOWN",1:$P(^DG(40.8,DGDIV,0),U,2))
  1.  . . I DGDIVNUM["UNKNOWN" S DGSORT("DIVISION",DGDIV,DGDIVNUM)=$P(DGENCTR(DGDIV,DGSDT),U)
  1.  . . ;1 = Sort by Patient Name
  1.  . . I '$D(@DGLIST@(DGDIV))  S @DGLIST@(DGDIVNUM)=$P(DGENCTR(DGDIV,DGSDT),U)
  1.  . . I $P(DGSORT("DGSRTBY"),U)=1 D
  1.  . . . I 1[$P(DGSORT("REPORT"),U) S @DGLIST@(DGDIVNUM,DGPTNM,I,DGCLCK)=DGTMP Q
  1.  . . . S @DGLIST@(DGPTNM,I,DGCLCK)=DGTMP
  1.  . . ;2 = Sort by Period
  1.  . . I $P(DGSORT("DGSRTBY"),U)=2 D
  1.  . . . I 1[$P(DGSORT("REPORT"),U) S @DGLIST@(DGDIVNUM,DGCLCK,I,DGPTNM)=DGTMP Q
  1.  . . . S @DGLIST@(DGCLCK,I,DGPTNM)=DGTMP
  1.  . . ;3 = Sort by Days Remaining
  1.  . . I $P(DGSORT("DGSRTBY"),U)=3 D
  1.  . . . I 1[$P(DGSORT("REPORT"),U) S @DGLIST@(DGDIVNUM,DGDYSLFT,I,DGPTNM,DGCLCK)=DGTMP Q
  1.  . . . S @DGLIST@(DGDYSLFT,I,DGPTNM,DGCLCK)=DGTMP
  1.  ;
  1.  I DGOLD'=DGPTNM S DGTOTAL=DGTOTAL+1,DGOLD=DGPTNM
  1.  I DGTOTAL>0 S @DGLIST@("DGTOTAL")=DGTOTAL
  1.  Q
  1.  ;
  1. CHKDATE(DGSDT,DGEDT) ;check if dates fall within the Begin and End dates
  1.  Q DGSORT("DGBEG")<=DGEDT&(DGSORT("DGEND")>=DGEDT)
  1.  ;
  1. PRINT(DGSORT,DGLIST) ;output report
  1.  N DGPAGE,DDASH,DGQ,DGSUB1,DGSUB2,DGSUB3,DGSUB4,DGSUB5
  1.  N DGSTR,DGOLD,DGOLD365,DGTOTAL,DGDIV,DGFAC,DGOEIEN,DGNEWDIV
  1.  S (DGQ,DGTOTAL,DGPAGE)=0,$P(DDASH,"-",81)=""
  1.  S DGTOTAL=$G(@DGLIST@("DGTOTAL"))
  1.  I $O(@DGLIST@(""))="" D  Q
  1.  . D HEAD
  1.  . W !!," >>> No OTH-90 records were found using the report criteria.",!
  1.  . D ASKCONT^DGOTHMG2
  1.  ; loop and print report
  1.  S (DGSUB1,DGSUB2,DGSUB3,DGSUB4,DGSUB5,DGSTR,DGOLD,DGOLD365,DGDIV)=""
  1.  I 1[$P(DGSORT("REPORT"),U) D
  1.  .S DGOEIEN="" F  S DGOEIEN=$O(DGSORT("DIVISION",DGOEIEN)) Q:DGOEIEN=""  D  Q:DGQ
  1.  ..S DGFAC="" F  S DGFAC=$O(DGSORT("DIVISION",DGOEIEN,DGFAC)) Q:DGFAC=""  D  Q:DGQ
  1.  ...D HEAD,DVISION(DGFAC) S DGNEWDIV=1
  1.  ...I '$D(@DGLIST@(DGFAC)) D  Q
  1.  ....W !," >>> No records were found for this Division.",!!
  1.  ....W ! D PAUSE^DGOTHRP2(.DGQ)
  1.  ....Q
  1.  ...D PRINT1(DGFAC)
  1.  ...S DGDIV=DGFAC
  1.  ...Q
  1.  ..Q
  1.  .Q
  1.  I 2[$P(DGSORT("REPORT"),U) D
  1.  . D HEAD
  1.  . S DGSUB1="" F  S DGSUB1=$O(@DGLIST@(DGSUB1)) Q:DGSUB1=""  D  Q:DGQ
  1.  . . D PRINT1(DGSUB1)
  1.  . Q:DGQ
  1.  . W ! D PAUSE^DGOTHRP2(.DGQ) Q:DGQ  W !
  1.  Q:DGQ
  1.  D HEAD D RPTSUM
  1.  Q
  1.  ;
  1.  ;DG*5.3*977 OTH-EXT
  1. PRINT1(DGSUB1) ;Print or display report by division
  1.  F  S DGSUB2=$O(@DGLIST@(DGSUB1,DGSUB2)) Q:DGSUB2=""  D  Q:DGQ
  1.  .F  S DGSUB3=$O(@DGLIST@(DGSUB1,DGSUB2,DGSUB3)) Q:DGSUB3=""  D  Q:DGQ
  1.  ..I 2[$P(DGSORT("REPORT"),U) Q:DGQ  D PRNTFC Q
  1.  ..F  S DGSUB4=$O(@DGLIST@(DGSUB1,DGSUB2,DGSUB3,DGSUB4)) Q:DGSUB4=""  D  Q:DGQ
  1.  ...K DGSTR
  1.  ...I $P(DGSORT("DGSRTBY"),U)=3,1[$P(DGSORT("REPORT"),U) Q:DGQ  D  Q
  1.  ....F  S DGSUB5=$O(@DGLIST@(DGSUB1,DGSUB2,DGSUB3,DGSUB4,DGSUB5)) Q:DGSUB5=""  D  Q:DGQ
  1.  .....S DGSTR=$G(@DGLIST@(DGSUB1,DGSUB2,DGSUB3,DGSUB4,DGSUB5)) D PRINT2
  1.  .....Q
  1.  ....Q
  1.  ...I $G(DGSTR)="" S DGSTR=$G(@DGLIST@(DGSUB1,DGSUB2,DGSUB3,DGSUB4))
  1.  ...D PRINT2 S DGNEWDIV=0
  1.  ..Q
  1.  .Q
  1.  Q:DGQ
  1.  I DGDIV'=DGSUB1,1[$P(DGSORT("REPORT"),U) W ! D PAUSE^DGOTHRP2(.DGQ) Q:DGQ  W !
  1.  Q
  1.  ;
  1. PRINT2 ;
  1.  W !
  1.  I $Y>(IOSL-4) D PAUSE(.DGQ) Q:DGQ  D HEAD W ! D DVISION(DGSUB1) W ! I DGOLD=DGSUB2 D PTNAME
  1.  I $P(DGSORT("DGSRTBY"),U)=1,DGNEWDIV!(DGSUB2'=DGOLD) D PTNAME S DGOLD=DGSUB2,DGOLD365=""
  1.  I $P(DGSORT("DGSRTBY"),U)=2!($P(DGSORT("DGSRTBY"),U)=3),DGNEWDIV!(DGSUB4'=DGOLD) W $E(DGSUB4,1,18),?20,$P(DGSTR,U,2) S DGOLD=DGSUB4,DGOLD365=""
  1.  I DGNEWDIV!(DGSUB3'=DGOLD365) W ?27,DGSUB3 S DGOLD365=DGSUB3
  1.  W ?31,$P(DGSTR,U),?35,$P(DGSTR,U,3),?47,$P(DGSTR,U,4),?59,$P(DGSTR,U,5),?65,$E($P(DGSTR,U,6),1,15)
  1.  Q
  1.  ;
  1. PTNAME ;diplay patient and PID
  1.  W $E(DGSUB2,1,18),?20,$P(DGSTR,U,2)
  1.  Q
  1.  ;
  1.  ;DG*5.3*977 OTH-EXT
  1. PRNTFC ;Print or display report by facility
  1.  K DGSTR
  1.  I $P(DGSORT("DGSRTBY"),U)=3 Q:DGQ  D  Q
  1.  . F  S DGSUB4=$O(@DGLIST@(DGSUB1,DGSUB2,DGSUB3,DGSUB4)) Q:DGSUB4=""  D  Q:DGQ
  1.  . . S DGSTR=$G(@DGLIST@(DGSUB1,DGSUB2,DGSUB3,DGSUB4))
  1.  . . D PRNTFC1
  1.  I $G(DGSTR)="" S DGSTR=$G(@DGLIST@(DGSUB1,DGSUB2,DGSUB3))
  1.  D PRNTFC1
  1.  Q
  1.  ;
  1. PRNTFC1 ;
  1.  W !
  1.  I $Y>(IOSL-4) D PAUSE(.DGQ) Q:DGQ  D HEAD W !
  1.  I $P(DGSORT("DGSRTBY"),U)=1,DGSUB1'=DGOLD W $E(DGSUB1,1,18),?20,$P(DGSTR,U,2) S DGOLD=DGSUB1,DGOLD365=""
  1.  I $P(DGSORT("DGSRTBY"),U)=2!($P(DGSORT("DGSRTBY"),U)=3),DGSUB3'=DGOLD W $E(DGSUB3,1,18),?20,$P(DGSTR,U,2) S DGOLD=DGSUB3,DGOLD365=""
  1.  I DGSUB2'=DGOLD365 W ?27,DGSUB2 S DGOLD365=DGSUB2
  1.  W ?31,$P(DGSTR,U),?35,$P(DGSTR,U,3),?47,$P(DGSTR,U,4),?59,$P(DGSTR,U,5),?65,$E($P(DGSTR,U,6),1,15)
  1.  Q:DGQ
  1.  Q
  1.  ;
  1. RPTSUM ;Display report summary
  1.  W !!,"REPORT SUMMARY:"
  1.  W !,"==============="
  1.  W !!,"Total "_$S(1[$P(DGSORT("DGSTATUS"),U):"Active",2[$P(DGSORT("DGSTATUS"),U):"Expired",1:"Active/Expired")
  1.  W " OTH 90-DAY PERIOD from ",$$FMTE^XLFDT($G(DGSORT("DGBEG")),"5Z")
  1.  W " to ",$$FMTE^XLFDT($G(DGSORT("DGEND")),"5Z"),":",$J($S(DGTOTAL>0:DGTOTAL,1:0),4),!
  1.  W !,"<END OF REPORT>"
  1.  D ASKCONT^DGOTHMG2
  1.  Q
  1.  ;
  1.  ;DG*5.3*977 OTH-EXT
  1. DVISION(DGFAC) ;
  1.  W "Division: ",DGSORT("DIVISION",DGOEIEN,DGFAC)_" ("_DGFAC_")",!
  1.  Q
  1.  ;
  1.  I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,DGQ)=1 Q
  1.  N DGFACLTY
  1.  I TRM!('TRM&DGPAGE) W @IOF
  1.  S DGPAGE=$G(DGPAGE)+1
  1.  S DGFACLTY="Facility: "_$P(HERE,U,2)
  1.  W !,?80-$L(ZTDESC)\2,$G(ZTDESC),?71,"Page:",?77,DGPAGE
  1.  W !,?80-$L(DGFACLTY)\2,DGFACLTY
  1.  W !,"Date Range:",?12,$$FMTE^XLFDT(DGSORT("DGBEG"),"5Z")_" TO "_$$FMTE^XLFDT(DGSORT("DGEND"),"5Z")
  1.  W ?45,"Sorted By:",?56,$S(2[$P(DGSORT("REPORT"),U):"",1:$P(DGSORT("REPORT"),U,2)_","),$P($G(DGSORT("DGSRTBY")),U,2)
  1.  W !,"Status    :",?12,$P($G(DGSORT("DGSTATUS")),U,2)
  1.  W ?45,"Printed  :",?56,$$FMTE^XLFDT($$NOW^XLFDT,"MP")
  1.  W !,DDASH
  1.  W !,"PATIENT NAME",?20,"PID",?26,"365",?31,"90",?35,"START DATE",?47,"END DATE",?59,"DAYS",?65,"AUTHORIZED BY"
  1.  W !,?26,"PRD",?31,"PRD",?59,"LEFT"
  1.  W !,DDASH
  1.  Q
  1.  ;
  1. PAUSE(DGQ) ; pause screen display
  1.  ; Input: 
  1.  ; DGQ - var used to quit report processing to user CRT
  1.  ; Output:
  1.  ; DGQ - passed by reference - 0 = Continue, 1 = Quit
  1.  ;
  1.  I $G(DGPAGE)>0,TRM K DIR S DIR(0)="E" D ^DIR K DIR S:+Y=0 DGQ=1
  1.  Q
  1.  ;
  1. EXIT ;
  1.  I $D(ZTQUEUED) S ZTREQ="@"  ;tell TaskMan to delete Task log entry
  1.  I '$D(ZTQUEUED) D
  1.  . I 'TRM,$Y>0 W @IOF
  1.  . K %ZIS,POP
  1.  . D ^%ZISC,HOME^%ZIS
  1.  Q