- 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 Jan 18, 2025@03:44:43 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