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

TIUPRD.m

Go to the documentation of this file.
  1. TIUPRD ; SLC/JER - Single patient print ;5/19/04
  1. ;;1.0;TEXT INTEGRATION UTILITIES;**1,100,121,182**;Jun 20, 1997
  1. ;
  1. REPLACE(TIUDA) ; Populate TMP array w records received,
  1. ;replacing ID kids w ID parents; replacing addenda with their parents
  1. ;or grandparents.
  1. ; Requires TIUDA.
  1. ; Sets ^TMP("TIUREPLACE",$J,IFN)=1 or 1^TIUDA, or 0
  1. ;where IFN is TIUDA or parent or grandparent of TIUDA.
  1. ; If TIUDA is replaced, then ^TMP("TIUREPLACE",$J,IFN)=1^TIUDA,
  1. ;to know what child the parent was included in the list for.
  1. ; Sets & passes back ^TMP("TIUREPLACE",$J) = # of elements in array.
  1. N IDPRNT,ADDPRNT,ADDGPNT
  1. S ^TMP("TIUREPLACE",$J)=+$G(^TMP("TIUREPLACE",$J))
  1. S IDPRNT=+$G(^TIU(8925,TIUDA,21)) ; ID parent
  1. ; -- If kid has parent that doesn't exist,
  1. ; treat kid as stand-alone:
  1. I '$D(^TIU(8925,IDPRNT,0)) S IDPRNT=0
  1. S ADDPRNT=$P(^TIU(8925,TIUDA,0),U,6)
  1. I ADDPRNT,'$D(^TIU(8925,ADDPRNT,0)) Q
  1. I ADDPRNT S ADDGPNT=+$G(^TIU(8925,ADDPRNT,21))
  1. I $G(ADDGPNT),'$D(^TIU(8925,ADDGPNT,0)) S ADDGPNT=0
  1. ;============================================
  1. ; -- If TIUDA is not an ID kid & not addm, just put it
  1. ; in array and quit: --
  1. I 'IDPRNT,'ADDPRNT D G REPX
  1. . ; -- If TIUDA is already in array (as parent/gpa of previous kid),
  1. . ; and is now received on its own merit, forget the original
  1. . ; child. If not already in array, put it in. Quit.
  1. . I $D(^TMP("TIUREPLACE",$J,TIUDA)) S $P(^TMP("TIUREPLACE",$J,TIUDA),U,2)="" Q
  1. . S ^TMP("TIUREPLACE",$J,TIUDA)=1
  1. . S ^TMP("TIUREPLACE",$J)=$G(^TMP("TIUREPLACE",$J))+1
  1. ; ==========================================
  1. ; -- If TIUDA is an ID kid, put its parent in array and track
  1. ; original child:
  1. I IDPRNT D G REPX
  1. . S ^TMP("TIUREPLACE",$J,IDPRNT)=1_U_TIUDA
  1. . S ^TMP("TIUREPLACE",$J)=$G(^TMP("TIUREPLACE",$J))+1
  1. ; ===========================================
  1. ; -- If TIUDA is an addm to standalone note, put parent in
  1. ; array and track orig addm:
  1. I ADDPRNT,'ADDGPNT D G REPX
  1. . S ^TMP("TIUREPLACE",$J,ADDPRNT)=1_U_TIUDA
  1. . S ^TMP("TIUREPLACE",$J)=$G(^TMP("TIUREPLACE",$J))+1
  1. ; ===========================================
  1. ; -- If TIUDA is an addm to ID kid, put ID parent in
  1. ; array and track orig addm:
  1. I ADDPRNT,ADDGPNT D G REPX
  1. . S ^TMP("TIUREPLACE",$J,ADDGPNT)=1_U_TIUDA
  1. . S ^TMP("TIUREPLACE",$J)=$G(^TMP("TIUREPLACE",$J))+1
  1. REPX Q
  1. ;
  1. MAIN(TIUTYP) ; Control Branching
  1. N DFN,TIU,TIUOUT,TIUREL,TIUCHK,TIUA,TIUSEE,ACT,TIUY,TIUFLAG
  1. N TIUDAT,TIUOUT,TIUSEE,TIUI,TIUQUIT,TIUDEV
  1. I '$D(TIUPRM0) D SETPARM^TIULE
  1. S:$D(ORVP) DFN=+ORVP S TIUTYP=$G(TIUTYP,38)
  1. D SELPAT^TIULA2(.TIUDAT,TIUTYP,+$G(DFN))
  1. I +$G(TIUDAT)'>0,($D(TIUDAT)'>9) S TIUOUT=1 Q
  1. S TIUFLAG=$$FLAG^TIUPRPN3
  1. S TIUDEV=$$DEVICE^TIUDEV(.IO) ; Get Device/allow queueing
  1. I IO']"" G PRINTX
  1. I $D(IO("Q")) D QUE^TIUDEV("PRINTN^TIUPRD",TIUDEV) G PRINTX
  1. D PRINTN
  1. PRINTX D ^%ZISC
  1. K ^TMP("TIUPR",$J)
  1. Q
  1. PRINTN ; Loop through selected doc's & invoke print code as appropriate
  1. N TIUI,TIUTYP,TIUDARR,DFN,TIULNO,DIROUT
  1. K ^TMP("TIUREPLACE",$J)
  1. U IO
  1. S TIUI=0
  1. F S TIUI=$O(TIUDAT(TIUI)) Q:+TIUI'>0 D Q:$D(DIROUT)
  1. . N TIUPGRP,TIUPMTHD,TIUPFHDR,TIUPFNBR,ORIGCHLD
  1. . S TIUDA=+$G(TIUDAT(TIUI))
  1. . I '+$G(^TIU(8925,+TIUDA,0)) Q
  1. . ; -- Set ^TMP("TIUREPLACE",$J),
  1. . ; with ID kids & adda replaced by parents:
  1. . D REPLACE(TIUDA)
  1. . S TIULNO(TIUDA)=TIUI
  1. ; -- Set TIUDARR w info needed to print TIUDA:
  1. S TIUDA=0 F S TIUDA=$O(^TMP("TIUREPLACE",$J,TIUDA)) Q:'TIUDA D
  1. . S TIUTYP=$P(^TIU(8925,TIUDA,0),U),DFN=$P(^(0),U,2)
  1. . I +TIUTYP D
  1. . . S TIUPMTHD=$$PRNTMTHD^TIULG(+TIUTYP)
  1. . . S TIUPGRP=$$PRNTGRP^TIULG(+TIUTYP)
  1. . . S TIUPFHDR=$$PRNTHDR^TIULG(+TIUTYP)
  1. . . S TIUPFNBR=$$PRNTNBR^TIULG(+TIUTYP)
  1. . Q:$G(TIUPMTHD)']""
  1. . S TIUI=$G(TIULNO(TIUDA))
  1. . I '$G(TIUI) D
  1. . . S ORIGCHLD=$P(^TMP("TIUREPLACE",$J,TIUDA),U,2),TIUI=$G(TIULNO(ORIGCHLD))
  1. . ;I +$G(TIUPGRP),($G(TIUPFHDR)]""),($G(TIUPFNBR)]"") S TIUDARR(TIUPMTHD,$G(TIUPGRP)_"$"_TIUPFHDR_";"_DFN,TIUI,TIUDA)=TIUPFNBR
  1. . ;E S TIUDARR(TIUPMTHD,DFN,TIUI,TIUDA)=""
  1. . ; -- P182: Set array same whether or not flds are defined, with
  1. . ; TIUPGRP piece possibly 0, TIUPFHDR piece possibly null, and
  1. . ; array value TIUPFNBR possibly null.
  1. . S TIUDARR(TIUPMTHD,+$G(TIUPGRP)_"$"_$G(TIUPFHDR)_";"_DFN,TIUI,TIUDA)=$G(TIUPFNBR)
  1. K ^TMP("TIUREPLACE",$J)
  1. ; -- Sort printout by printmethod (prints similar docmts together):
  1. S TIUPMTHD="" F S TIUPMTHD=$O(TIUDARR(TIUPMTHD)) Q:TIUPMTHD="" D
  1. . D PRNTDOC^TIURA(TIUPMTHD,.TIUDARR)
  1. Q