TIUPRD ; SLC/JER - Single patient print ;5/19/04
;;1.0;TEXT INTEGRATION UTILITIES;**1,100,121,182**;Jun 20, 1997
;
REPLACE(TIUDA) ; Populate TMP array w records received,
;replacing ID kids w ID parents; replacing addenda with their parents
;or grandparents.
; Requires TIUDA.
; Sets ^TMP("TIUREPLACE",$J,IFN)=1 or 1^TIUDA, or 0
;where IFN is TIUDA or parent or grandparent of TIUDA.
; If TIUDA is replaced, then ^TMP("TIUREPLACE",$J,IFN)=1^TIUDA,
;to know what child the parent was included in the list for.
; Sets & passes back ^TMP("TIUREPLACE",$J) = # of elements in array.
N IDPRNT,ADDPRNT,ADDGPNT
S ^TMP("TIUREPLACE",$J)=+$G(^TMP("TIUREPLACE",$J))
S IDPRNT=+$G(^TIU(8925,TIUDA,21)) ; ID parent
; -- If kid has parent that doesn't exist,
; treat kid as stand-alone:
I '$D(^TIU(8925,IDPRNT,0)) S IDPRNT=0
S ADDPRNT=$P(^TIU(8925,TIUDA,0),U,6)
I ADDPRNT,'$D(^TIU(8925,ADDPRNT,0)) Q
I ADDPRNT S ADDGPNT=+$G(^TIU(8925,ADDPRNT,21))
I $G(ADDGPNT),'$D(^TIU(8925,ADDGPNT,0)) S ADDGPNT=0
;============================================
; -- If TIUDA is not an ID kid & not addm, just put it
; in array and quit: --
I 'IDPRNT,'ADDPRNT D G REPX
. ; -- If TIUDA is already in array (as parent/gpa of previous kid),
. ; and is now received on its own merit, forget the original
. ; child. If not already in array, put it in. Quit.
. I $D(^TMP("TIUREPLACE",$J,TIUDA)) S $P(^TMP("TIUREPLACE",$J,TIUDA),U,2)="" Q
. S ^TMP("TIUREPLACE",$J,TIUDA)=1
. S ^TMP("TIUREPLACE",$J)=$G(^TMP("TIUREPLACE",$J))+1
; ==========================================
; -- If TIUDA is an ID kid, put its parent in array and track
; original child:
I IDPRNT D G REPX
. S ^TMP("TIUREPLACE",$J,IDPRNT)=1_U_TIUDA
. S ^TMP("TIUREPLACE",$J)=$G(^TMP("TIUREPLACE",$J))+1
; ===========================================
; -- If TIUDA is an addm to standalone note, put parent in
; array and track orig addm:
I ADDPRNT,'ADDGPNT D G REPX
. S ^TMP("TIUREPLACE",$J,ADDPRNT)=1_U_TIUDA
. S ^TMP("TIUREPLACE",$J)=$G(^TMP("TIUREPLACE",$J))+1
; ===========================================
; -- If TIUDA is an addm to ID kid, put ID parent in
; array and track orig addm:
I ADDPRNT,ADDGPNT D G REPX
. S ^TMP("TIUREPLACE",$J,ADDGPNT)=1_U_TIUDA
. S ^TMP("TIUREPLACE",$J)=$G(^TMP("TIUREPLACE",$J))+1
REPX Q
;
MAIN(TIUTYP) ; Control Branching
N DFN,TIU,TIUOUT,TIUREL,TIUCHK,TIUA,TIUSEE,ACT,TIUY,TIUFLAG
N TIUDAT,TIUOUT,TIUSEE,TIUI,TIUQUIT,TIUDEV
I '$D(TIUPRM0) D SETPARM^TIULE
S:$D(ORVP) DFN=+ORVP S TIUTYP=$G(TIUTYP,38)
D SELPAT^TIULA2(.TIUDAT,TIUTYP,+$G(DFN))
I +$G(TIUDAT)'>0,($D(TIUDAT)'>9) S TIUOUT=1 Q
S TIUFLAG=$$FLAG^TIUPRPN3
S TIUDEV=$$DEVICE^TIUDEV(.IO) ; Get Device/allow queueing
I IO']"" G PRINTX
I $D(IO("Q")) D QUE^TIUDEV("PRINTN^TIUPRD",TIUDEV) G PRINTX
D PRINTN
PRINTX D ^%ZISC
K ^TMP("TIUPR",$J)
Q
PRINTN ; Loop through selected doc's & invoke print code as appropriate
N TIUI,TIUTYP,TIUDARR,DFN,TIULNO,DIROUT
K ^TMP("TIUREPLACE",$J)
U IO
S TIUI=0
F S TIUI=$O(TIUDAT(TIUI)) Q:+TIUI'>0 D Q:$D(DIROUT)
. N TIUPGRP,TIUPMTHD,TIUPFHDR,TIUPFNBR,ORIGCHLD
. S TIUDA=+$G(TIUDAT(TIUI))
. I '+$G(^TIU(8925,+TIUDA,0)) Q
. ; -- Set ^TMP("TIUREPLACE",$J),
. ; with ID kids & adda replaced by parents:
. D REPLACE(TIUDA)
. S TIULNO(TIUDA)=TIUI
; -- Set TIUDARR w info needed to print TIUDA:
S TIUDA=0 F S TIUDA=$O(^TMP("TIUREPLACE",$J,TIUDA)) Q:'TIUDA D
. S TIUTYP=$P(^TIU(8925,TIUDA,0),U),DFN=$P(^(0),U,2)
. I +TIUTYP D
. . S TIUPMTHD=$$PRNTMTHD^TIULG(+TIUTYP)
. . S TIUPGRP=$$PRNTGRP^TIULG(+TIUTYP)
. . S TIUPFHDR=$$PRNTHDR^TIULG(+TIUTYP)
. . S TIUPFNBR=$$PRNTNBR^TIULG(+TIUTYP)
. Q:$G(TIUPMTHD)']""
. S TIUI=$G(TIULNO(TIUDA))
. I '$G(TIUI) D
. . S ORIGCHLD=$P(^TMP("TIUREPLACE",$J,TIUDA),U,2),TIUI=$G(TIULNO(ORIGCHLD))
. ;I +$G(TIUPGRP),($G(TIUPFHDR)]""),($G(TIUPFNBR)]"") S TIUDARR(TIUPMTHD,$G(TIUPGRP)_"$"_TIUPFHDR_";"_DFN,TIUI,TIUDA)=TIUPFNBR
. ;E S TIUDARR(TIUPMTHD,DFN,TIUI,TIUDA)=""
. ; -- P182: Set array same whether or not flds are defined, with
. ; TIUPGRP piece possibly 0, TIUPFHDR piece possibly null, and
. ; array value TIUPFNBR possibly null.
. S TIUDARR(TIUPMTHD,+$G(TIUPGRP)_"$"_$G(TIUPFHDR)_";"_DFN,TIUI,TIUDA)=$G(TIUPFNBR)
K ^TMP("TIUREPLACE",$J)
; -- Sort printout by printmethod (prints similar docmts together):
S TIUPMTHD="" F S TIUPMTHD=$O(TIUDARR(TIUPMTHD)) Q:TIUPMTHD="" D
. D PRNTDOC^TIURA(TIUPMTHD,.TIUDARR)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUPRD 4529 printed Oct 16, 2024@18:44:09 Page 2
TIUPRD ; SLC/JER - Single patient print ;5/19/04
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**1,100,121,182**;Jun 20, 1997
+2 ;
REPLACE(TIUDA) ; Populate TMP array w records received,
+1 ;replacing ID kids w ID parents; replacing addenda with their parents
+2 ;or grandparents.
+3 ; Requires TIUDA.
+4 ; Sets ^TMP("TIUREPLACE",$J,IFN)=1 or 1^TIUDA, or 0
+5 ;where IFN is TIUDA or parent or grandparent of TIUDA.
+6 ; If TIUDA is replaced, then ^TMP("TIUREPLACE",$J,IFN)=1^TIUDA,
+7 ;to know what child the parent was included in the list for.
+8 ; Sets & passes back ^TMP("TIUREPLACE",$J) = # of elements in array.
+9 NEW IDPRNT,ADDPRNT,ADDGPNT
+10 SET ^TMP("TIUREPLACE",$JOB)=+$GET(^TMP("TIUREPLACE",$JOB))
+11 ; ID parent
SET IDPRNT=+$GET(^TIU(8925,TIUDA,21))
+12 ; -- If kid has parent that doesn't exist,
+13 ; treat kid as stand-alone:
+14 IF '$DATA(^TIU(8925,IDPRNT,0))
SET IDPRNT=0
+15 SET ADDPRNT=$PIECE(^TIU(8925,TIUDA,0),U,6)
+16 IF ADDPRNT
IF '$DATA(^TIU(8925,ADDPRNT,0))
QUIT
+17 IF ADDPRNT
SET ADDGPNT=+$GET(^TIU(8925,ADDPRNT,21))
+18 IF $GET(ADDGPNT)
IF '$DATA(^TIU(8925,ADDGPNT,0))
SET ADDGPNT=0
+19 ;============================================
+20 ; -- If TIUDA is not an ID kid & not addm, just put it
+21 ; in array and quit: --
+22 IF 'IDPRNT
IF 'ADDPRNT
Begin DoDot:1
+23 ; -- If TIUDA is already in array (as parent/gpa of previous kid),
+24 ; and is now received on its own merit, forget the original
+25 ; child. If not already in array, put it in. Quit.
+26 IF $DATA(^TMP("TIUREPLACE",$JOB,TIUDA))
SET $PIECE(^TMP("TIUREPLACE",$JOB,TIUDA),U,2)=""
QUIT
+27 SET ^TMP("TIUREPLACE",$JOB,TIUDA)=1
+28 SET ^TMP("TIUREPLACE",$JOB)=$GET(^TMP("TIUREPLACE",$JOB))+1
End DoDot:1
GOTO REPX
+29 ; ==========================================
+30 ; -- If TIUDA is an ID kid, put its parent in array and track
+31 ; original child:
+32 IF IDPRNT
Begin DoDot:1
+33 SET ^TMP("TIUREPLACE",$JOB,IDPRNT)=1_U_TIUDA
+34 SET ^TMP("TIUREPLACE",$JOB)=$GET(^TMP("TIUREPLACE",$JOB))+1
End DoDot:1
GOTO REPX
+35 ; ===========================================
+36 ; -- If TIUDA is an addm to standalone note, put parent in
+37 ; array and track orig addm:
+38 IF ADDPRNT
IF 'ADDGPNT
Begin DoDot:1
+39 SET ^TMP("TIUREPLACE",$JOB,ADDPRNT)=1_U_TIUDA
+40 SET ^TMP("TIUREPLACE",$JOB)=$GET(^TMP("TIUREPLACE",$JOB))+1
End DoDot:1
GOTO REPX
+41 ; ===========================================
+42 ; -- If TIUDA is an addm to ID kid, put ID parent in
+43 ; array and track orig addm:
+44 IF ADDPRNT
IF ADDGPNT
Begin DoDot:1
+45 SET ^TMP("TIUREPLACE",$JOB,ADDGPNT)=1_U_TIUDA
+46 SET ^TMP("TIUREPLACE",$JOB)=$GET(^TMP("TIUREPLACE",$JOB))+1
End DoDot:1
GOTO REPX
REPX QUIT
+1 ;
MAIN(TIUTYP) ; Control Branching
+1 NEW DFN,TIU,TIUOUT,TIUREL,TIUCHK,TIUA,TIUSEE,ACT,TIUY,TIUFLAG
+2 NEW TIUDAT,TIUOUT,TIUSEE,TIUI,TIUQUIT,TIUDEV
+3 IF '$DATA(TIUPRM0)
DO SETPARM^TIULE
+4 if $DATA(ORVP)
SET DFN=+ORVP
SET TIUTYP=$GET(TIUTYP,38)
+5 DO SELPAT^TIULA2(.TIUDAT,TIUTYP,+$GET(DFN))
+6 IF +$GET(TIUDAT)'>0
IF ($DATA(TIUDAT)'>9)
SET TIUOUT=1
QUIT
+7 SET TIUFLAG=$$FLAG^TIUPRPN3
+8 ; Get Device/allow queueing
SET TIUDEV=$$DEVICE^TIUDEV(.IO)
+9 IF IO']""
GOTO PRINTX
+10 IF $DATA(IO("Q"))
DO QUE^TIUDEV("PRINTN^TIUPRD",TIUDEV)
GOTO PRINTX
+11 DO PRINTN
PRINTX DO ^%ZISC
+1 KILL ^TMP("TIUPR",$JOB)
+2 QUIT
PRINTN ; Loop through selected doc's & invoke print code as appropriate
+1 NEW TIUI,TIUTYP,TIUDARR,DFN,TIULNO,DIROUT
+2 KILL ^TMP("TIUREPLACE",$JOB)
+3 USE IO
+4 SET TIUI=0
+5 FOR
SET TIUI=$ORDER(TIUDAT(TIUI))
if +TIUI'>0
QUIT
Begin DoDot:1
+6 NEW TIUPGRP,TIUPMTHD,TIUPFHDR,TIUPFNBR,ORIGCHLD
+7 SET TIUDA=+$GET(TIUDAT(TIUI))
+8 IF '+$GET(^TIU(8925,+TIUDA,0))
QUIT
+9 ; -- Set ^TMP("TIUREPLACE",$J),
+10 ; with ID kids & adda replaced by parents:
+11 DO REPLACE(TIUDA)
+12 SET TIULNO(TIUDA)=TIUI
End DoDot:1
if $DATA(DIROUT)
QUIT
+13 ; -- Set TIUDARR w info needed to print TIUDA:
+14 SET TIUDA=0
FOR
SET TIUDA=$ORDER(^TMP("TIUREPLACE",$JOB,TIUDA))
if 'TIUDA
QUIT
Begin DoDot:1
+15 SET TIUTYP=$PIECE(^TIU(8925,TIUDA,0),U)
SET DFN=$PIECE(^(0),U,2)
+16 IF +TIUTYP
Begin DoDot:2
+17 SET TIUPMTHD=$$PRNTMTHD^TIULG(+TIUTYP)
+18 SET TIUPGRP=$$PRNTGRP^TIULG(+TIUTYP)
+19 SET TIUPFHDR=$$PRNTHDR^TIULG(+TIUTYP)
+20 SET TIUPFNBR=$$PRNTNBR^TIULG(+TIUTYP)
End DoDot:2
+21 if $GET(TIUPMTHD)']""
QUIT
+22 SET TIUI=$GET(TIULNO(TIUDA))
+23 IF '$GET(TIUI)
Begin DoDot:2
+24 SET ORIGCHLD=$PIECE(^TMP("TIUREPLACE",$JOB,TIUDA),U,2)
SET TIUI=$GET(TIULNO(ORIGCHLD))
End DoDot:2
+25 ;I +$G(TIUPGRP),($G(TIUPFHDR)]""),($G(TIUPFNBR)]"") S TIUDARR(TIUPMTHD,$G(TIUPGRP)_"$"_TIUPFHDR_";"_DFN,TIUI,TIUDA)=TIUPFNBR
+26 ;E S TIUDARR(TIUPMTHD,DFN,TIUI,TIUDA)=""
+27 ; -- P182: Set array same whether or not flds are defined, with
+28 ; TIUPGRP piece possibly 0, TIUPFHDR piece possibly null, and
+29 ; array value TIUPFNBR possibly null.
+30 SET TIUDARR(TIUPMTHD,+$GET(TIUPGRP)_"$"_$GET(TIUPFHDR)_";"_DFN,TIUI,TIUDA)=$GET(TIUPFNBR)
End DoDot:1
+31 KILL ^TMP("TIUREPLACE",$JOB)
+32 ; -- Sort printout by printmethod (prints similar docmts together):
+33 SET TIUPMTHD=""
FOR
SET TIUPMTHD=$ORDER(TIUDARR(TIUPMTHD))
if TIUPMTHD=""
QUIT
Begin DoDot:1
+34 DO PRNTDOC^TIURA(TIUPMTHD,.TIUDARR)
End DoDot:1
+35 QUIT
