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

DGPPRRP1.m

Go to the documentation of this file.
  1. DGPPRRP1 ;SLC/RM - PRESUMPTIVE PSYCHOSIS RECONCILIATION REPORT CONTINUATION ; Dec 02, 2020@3:00 pm
  1. ;;5.3;Registration;**1034,1035**;Aug 13, 1993;Build 14
  1. ;
  1. ;External References Supported by ICR# Type
  1. ;------------------- ----------------- ---------
  1. ; $$S^%ZTLOAD 10063 Supported
  1. ; ^DIR 10026 Supported
  1. ; $$FMTE^XLFDT 10103 Supported
  1. ; $$NOW^XLFDT 10103 Supported
  1. ; $$CJ^XLFSTR 10104 Supported
  1. Q
  1. ;
  1. PRINTPP(DGSORT,DGPPLST) ;output report
  1. N DGPAGE,DDASH,DGQ,DGDFN,DGTOTAL,DGPRINT,DGOLD,DGSTATN,DGPTNAME
  1. S (DGQ,DGTOTAL,DGPAGE,DGPRINT,DGOLD)=0,$P(DDASH,"=",81)=""
  1. I $O(@DGPPLST@(""))="" D Q
  1. . D HEADER,COLHEAD
  1. . W !!!," >>> No records were found using the report criteria.",!!
  1. . W ! D LINE
  1. . D ASKCONT(0)
  1. D HEADER,COLHEAD ; loop and print report
  1. S DGPTNAME="" F S DGPTNAME=$O(@DGPPLST@(DGPTNAME)) Q:DGPTNAME="" D Q:DGQ
  1. . I DGOLD'=DGPTNAME S DGPRINT=0
  1. . S DGDFN="" F S DGDFN=$O(@DGPPLST@(DGPTNAME,DGDFN)) Q:DGDFN="" D Q:DGQ
  1. . . I 'DGPRINT D PRINT1 S DGPRINT=1
  1. . . I $O(@DGPPLST@(DGPTNAME,DGDFN,""))'="" D PRNTOED ;display patient's other eligibilities if there are any AND date of service
  1. . S DGTOTAL=DGTOTAL+1
  1. . S DGOLD=DGPTNAME
  1. . Q:DGQ
  1. W !
  1. Q:DGQ
  1. D LINE
  1. W !!,"Number of Unique Patients: ",$J(DGTOTAL,5)
  1. W !!,"<< end of report >>"
  1. D ASKCONT(0) W @IOF
  1. Q
  1. ;
  1. PRINT1 ;print the name, pid, DOB, DOD, PE, Other PE, and PP Category only once
  1. N DGDOD,JJ,DGOTHER
  1. W !
  1. S DGDOD=$P(@DGPPLST@(DGPTNAME,DGDFN),U,4)
  1. W $E(DGPTNAME,1,24) ;patient name
  1. W ?26,$P(@DGPPLST@(DGPTNAME,DGDFN),U,2) ;PID
  1. W ?33,$$FMTE^XLFDT($P(@DGPPLST@(DGPTNAME,DGDFN),U,3),"5Z") ;DOB
  1. W ?45,$S(+DGDOD>0:$$FMTE^XLFDT(DGDOD\1,"5Z"),1:"N/A") ;Date of Death (DOD)
  1. W ?57,$P(@DGPPLST@(DGPTNAME,DGDFN),U,5) ;PP Category
  1. W ?63,$E($P(@DGPPLST@(DGPTNAME,DGDFN),U,6),1,29) ;Primary eligibility
  1. Q
  1. ;
  1. PRNTOED ;display patient's other eligibilities if there are any and date of service
  1. N RCNT,DGSTATN,DGPRINT2,DGDOS,CNTR,FILENO,DATEDOS
  1. S CNTR=0
  1. S DGDOS="" F S DGDOS=$O(@DGPPLST@(DGPTNAME,DGDFN,DGDOS)) Q:DGDOS="" D Q:DGQ
  1. . S RCNT="" F S RCNT=$O(@DGPPLST@(DGPTNAME,DGDFN,DGDOS,RCNT)) Q:RCNT="" D Q:DGQ
  1. . . S FILENO="" F S FILENO=$O(@DGPPLST@(DGPTNAME,DGDFN,DGDOS,RCNT,"OTHER",FILENO)) Q:FILENO="" D Q:DGQ
  1. . . . S DGSTATN="" F S DGSTATN=$O(@DGPPLST@(DGPTNAME,DGDFN,DGDOS,RCNT,"OTHER",FILENO,DGSTATN)) Q:DGSTATN="" D Q:DGQ
  1. . . . . I $Y>(IOSL-4) W ! D PAUSE(.DGQ) Q:DGQ D HEADER,COLHEAD,PRINT1 S CNTR=0
  1. . . . . I CNTR>0 W !
  1. . . . . W ?94,$E($P(@DGPPLST@(DGPTNAME,DGDFN,DGDOS,RCNT,"OTHER",FILENO,DGSTATN),U,2),1,26) ;write other eligibility
  1. . . . . S DATEDOS=$P(@DGPPLST@(DGPTNAME,DGDFN,DGDOS,RCNT,"OTHER",FILENO,DGSTATN),U)
  1. . . . . I DATEDOS["*" W ?121,$E(DATEDOS,"*",1) S DATEDOS=$P(DATEDOS,"*",2)
  1. . . . . W ?122,$S(+DATEDOS>0:$$FMTE^XLFDT(DATEDOS\1,"5Z"),1:"") ;date of service
  1. . . . . S CNTR=CNTR+1
  1. Q
  1. ;
  1. N DGFACLTY,DGDTRNGE,DTPRNTD
  1. I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,DGQ)=1 Q
  1. I TRM!('TRM&DGPAGE) W @IOF
  1. S DGPAGE=$G(DGPAGE)+1
  1. W ?(132-$L(ZTDESC))\2,$G(ZTDESC),?120,"Page: ",?127,DGPAGE
  1. W !,?47,"DATE RANGE: ",$$FMTE^XLFDT(DGSORT("DGBEG"),"5Z")," TO ",$$FMTE^XLFDT(DGSORT("DGEND"),"5Z")
  1. W !,?45,"DATE PRINTED: ",$$FMTE^XLFDT($$NOW^XLFDT,"MP")
  1. W !,?48,"FACILITY : "_$P(HERE,U,2)
  1. W !,?47,"'*' = Patient Admission Date"
  1. W ! D LINE W !
  1. Q
  1. ;
  1. LINE ;prints double dash line
  1. N LINE
  1. F LINE=1:1:132 W "="
  1. Q
  1. ;
  1. COLHEAD ;report column header
  1. W "PATIENT NAME",?26,"PID",?33,"DATE OF",?45,"DATE OF",?57,"PP",?63,"PRIMARY",?94,"OTHER",?122,"DATE OF"
  1. W !,?33,"BIRTH",?45,"DEATH",?57,"CAT",?63,"ELIGIBILITY",?94,"ELIGIBILITIES",?122,"SERVICE"
  1. W !,"------------------------",?26,"-----",?33,"----------",?45,"----------",?57,"----"
  1. W ?63,"-----------------------------",?94,"-------------------------",?122,"----------"
  1. Q
  1. ;
  1. ASKCONT(FLAG) ; display "press <Enter> to continue" prompt
  1. N Z
  1. W !!,$$CJ^XLFSTR("Press <Enter> to "_$S(FLAG=1:"continue.",1:"exit."),20)
  1. R !,Z:DTIME
  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. I $G(DGPAGE)>0,TRM K DIR S DIR(0)="E" D ^DIR K DIR S:+Y=0 DGQ=1
  1. Q
  1. ;