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

TIUPRDS2.m

Go to the documentation of this file. 
  1. TIUPRDS2 ;SLC/SBW - Header & Footer for Form 10-1000 ; 11/29/02
  1.  ;;1.0;TEXT INTEGRATION UTILITIES;**7,55,52,148**;Jun 20, 1997
  1.  ;IHS/ITSC/LJF 02/26/2003 removed VA form # from print
  1.  ;                        put name of document under patient for footer
  1.  ;                        shortened header
  1.  ;
  1.  ; position, write footer when appropriate
  1.  ; IF TIUHDR=1, HEADER WILL NOT BE PRINTED
  1.  S TIUCONT=1 G:$Y+TIUY'>IOSL FOOTEXIT
  1.  ;
  1.  ;IHS/ITSC/LJF 02/26/2003 IHS version of footer
  1.  ;I (IOT'="HFS")!(IOSL<250) F  Q:$Y+4>IOSL  W ! ;moves ftr to pg bottom
  1.  ;I $E(IOST)="P" D
  1.  ;. W !,"PATIENT: ",^TMP("TIULQ",$J,TIUDA,.02,"E")
  1.  ;. W ?47,"VA FORM 10-1000 DISCHARGE SUMMARY"
  1.  ;. W !,TIU("SSN"),"  DOB: ",$$DATE^TIULS(+$G(TIU("DOB")),"MM/DD/CCYY")
  1.  I (IOT'="HFS")!(IOSL<250) F  Q:$Y+5>IOSL  W ! ;moves ftr to pg bottom
  1.  I $E(IOST)="P" D
  1.  . W !,$$REPEAT^XLFSTR("-",80)
  1.  . W !,"PATIENT: ",^TMP("TIULQ",$J,TIUDA,.02,"E")
  1.  . W "  ",TIU("SSN"),"   #",TIU("HRCN")
  1.  . W !,$$GET1^DIQ(8925,+TIUDA,.01)
  1.  ;IHS/ITSC/LJF 02/26/2003
  1.  ;
  1.  W ?40,$J(TIUCOPY,39)
  1.  I $E(IOST)="C" S TIUCONT=$$STOP^TIUU G FOOTEXIT:'TIUCONT
  1.  W @IOF
  1.  D:'+$G(TIUHDR) HEADER(TIUDA,.TIU,TIUFLAG,.TIUPAGE)
  1. FOOTEXIT ;
  1.  Q TIUCONT
  1.  N TIULINE,TIUADT,TIUENTDT S $P(TIULINE,"-",80)=""
  1.  S TIUENTDT=+$G(^TIU(8925,+TIUDA,12))
  1.  S TIUADT=$S(+$G(TIU("LDT")):TIU("LDT"),+TIUENTDT:TIUENTDT,+$G(TIU("EDT")):TIU("EDT"),1:0)
  1.  I +$G(TIU("DOB")),+TIUADT S TIU("AGE")=$$AGE(TIUADT,+$G(TIU("DOB")))
  1.  W:'+TIUFLAG&($E(IOST)="P") ?26,"** WORK COPY - NOT FOR MEDICAL RECORD **"
  1.  W !,$E($P($G(TIU("DIV")),U,2),1,37),?$X+3,$S(^TMP("TIULQ",$J,TIUDA,.09,"I")="P":^("E"),1:"")
  1.  W ?50,$$DATE^TIULS($$NOW^TIULC,"MM/DD/CCYY HR:MIN"),?71,"Page: ",$J(TIUPAGE,2)
  1.  W !,$$REPEAT^XLFSTR("_",80) S TIUPAGE=TIUPAGE+1 Q     ;IHS/ITSC/LJF 02/26/2003 shortened header by quitting here
  1.  W !,TIULINE
  1.  ; Removed RACE from header **148**
  1.  W !,"PATIENT NAME",?33,"| AGE | SEX |    SSN       | CLAIM NUMBER"
  1.  W !,^TMP("TIULQ",$J,TIUDA,.02,"E"),?33,"| ",$J($G(TIU("AGE")),3),?39,"|",?42,$P($G(TIU("SEX")),U),?45,"| ",$P($G(TIU("SSN")),U),?60,"| ",$G(TIU("CLAIM"))
  1.  W !,TIULINE
  1.  G:$E(IOST)="C"&(TIUPAGE>1) HEADERX ;Next lines not displayed on screen if page > 0
  1.  W !?2,"ADM DATE   |  DISC DATE   | TYPE OF RELEASE   | INP | ABS | WARD NO"
  1.  W !,$P(^TMP("TIULQ",$J,TIUDA,.07,"E"),"@"),?13,"| ",$P(^TMP("TIULQ",$J,TIUDA,.08,"E"),"@"),?28,"| "
  1.  W $S($G(^TMP("TIULQ",$J,TIUDA,.08,"E"))]"":$$DISPTYP($P($G(TIU("MTYPE")),U,2)),1:" "),?48,"|"
  1.  W ?49,$J($P($G(TIU("DAYS")),U),4),?54,"|",?55,$J($P($G(TIU("DAYS")),U,4),4),?60,"| ",$E($P($G(TIU("WARD")),U,2),1,18)
  1.  W !,TIULINE
  1. HEADERX ;Header exit
  1.  S TIUPAGE=TIUPAGE+1
  1.  Q
  1. AGE(TIUDT,TIUDOB) ; Compute patient's age as of discharge (or entry)
  1.  N Y S Y=$$FMDIFF^XLFDT(TIUDT,TIUDOB)\365.25
  1.  Q Y
  1. DISPTYP(TEXT) ; NOIS SHE-1098-52553
  1.  N TIUY
  1.  I TEXT="NON-SERVICE CONNECTED (OPT-NSC)" S TIUY="NON-SERV (OPT-NSC)"
  1.  E  I TEXT="CONTINUED ASIH (OTHER FACILITY)" S TIUY="CONTINUED ASIH"
  1.  E  I TEXT="DISCHARGE FROM NHCU/DOM WHILE ASIH" S TIUY="DISC NHCU/DOM ASIH"
  1.  E  S TIUY=$E(TEXT,1,18)
  1.  Q TIUY