TIUPRPN5 ;SLC/MJC-Sort PNs for Prting by Location;6/26/01
;;1.0;TEXT INTEGRATION UTILITIES;**100,121**;Jun 20, 1997
;
LOC ;sorts PNs for prting by CLINIC location
;these notes are chartable contiguous or separate
;this option is screened to exclude WARDs
;sites should use the [TIU PRINT PN WARD] option which sorts
;by BED NUMBER for current inpts on that ward for INPT notes
;[TIU PRINT PN OUTPT LOC]
;
N DIC,Y,TIUQT,TIULOC
D SETUP^TIUPRPN3("Print Progress Notes for OUTPATIENT LOCATION")
DIC F D Q:$D(TIUQT)
.S DIC=8925.93,DIC(0)="AEQMNZ",DIC("A")="Select OUTPATIENT location: "
.S DIC("S")="I $P($G(^SC(+$P($G(^TIU(8925.93,+Y,0)),U),0)),U,3)'=""W"""
.W ! D ^DIC K DIC("S") I Y<0 S TIUQT=1 Q
.S TIULOC=+Y(0)_U_+Y_U_Y(0,0)
.I '$D(^TIU(8925,"ALOCP",+TIULOC)) D Q
..W !,$C(7),"There are no signed Progress Notes for this location!!"
.D NOTES(TIULOC)
Q
;
NOTES(TIULOC) ;returns date/time;ien of last note prted
N OLD,NEW,Y,BEG,IFN,TIUSPG,CTR,TIULAST,ANS,MSG,TIUQT,DFN,SORT
K ^TMP("TIUREPLACE",$J)
S MSG=1,TIULAST=$P($G(^TIU(8925.93,+$P(TIULOC,U,2),1)),U,2)
I TIULAST]"" D Q:$D(TIUQT)
.I '+$G(TIULAST)!'$P(TIULAST,";",2)!('$D(^TIU(8925,"ALOCP",+TIULOC,+TIULAST,+$P(TIULAST,";",2)))) S $P(^TIU(8925.93,+$P(TIULOC,U,2),1),U,2)="",MSG=2 Q
.S BEG=+TIULAST
.W !!,"The last note printed for this location using this option was "
.W !,"signed ",$$FMTE^XLFDT(BEG,"1P"),!!
.S ANS=$$READ^TIUU("YA","Print from this point on? ","YES","^D HELP^TIUPRPN5")
.I $D(DIRUT) S TIUQT=1 Q
.I +$G(ANS) S IFN=$P(TIULAST,U,2) Q
.S $P(^TIU(8925.93,+$P(TIULOC,U,2),1),U,2)="",MSG=3
I $P($G(^TIU(8925.93,+$P(TIULOC,U,2),1)),U,2)']"" D Q:$D(TIUQT)
.D @MSG ;writes message to explain date selection
RANGE .S OLD=$O(^TIU(8925,"ALOCP",+TIULOC,0))
.S NEW=$O(^TIU(8925,"ALOCP",+TIULOC,9999999),-1)
.W !," The OLDEST note was signed: ",$$FMTE^XLFDT(OLD,"1P")
.W !,"The MOST RECENT note was signed: ",$$FMTE^XLFDT(NEW,"1P"),!
.W !,"Select a date and I will print all signed notes for "
.W !,$P(TIULOC,U,3)," from this date until NOW.",!
DATE .S %DT="AEPX",%DT(0)="-NOW",%DT("A")="Print Notes Beginning: "
.D ^%DT K %DT I $D(DTOUT)!(Y<0) S TIUQT=1 Q
.I Y>NEW W $C(7),!?5,"Pick a date between the OLDEST and the MOST "
.I W "RECENT." G DATE
.S BEG=Y
S CTR=0 F S BEG=$O(^TIU(8925,"ALOCP",+TIULOC,BEG)) Q:'BEG D
.I '$D(IFN) S IFN=0
.F S IFN=$O(^TIU(8925,"ALOCP",+TIULOC,BEG,IFN)) Q:'IFN D
..W "." D REPLACE^TIUPRPN3(IFN,BEG,1501)
S IFN=0 F S IFN=$O(^TMP("TIUREPLACE",$J,IFN)) Q:'IFN D
.S DFN=$P(^TIU(8925,IFN,0),U,2),SORT=$P(^DPT(DFN,0),U)_";"_DFN
.S BEG=^TMP("TIUREPLACE",$J,IFN,"DT")
.S ^TMP("TIUPR",$J,SORT,BEG,IFN)="Vice SF 509"
.S TIULAST=BEG_";"_IFN
S CTR=+$G(^TMP("TIUREPLACE",$J))
I CTR=0 W $C(7),!!,"No notes have been signed for this location since "
I W $$FMTE^XLFDT(+TIULAST,"1P") G NOTESX
W !,">> "_CTR_" note"_$S(CTR>1:"s",1:"")_" found for "_$P(TIULOC,U,3)
I CTR'>1 S TIUSPG=1
E S TIUSPG=$$PAGE^TIUPRPN3 G:TIUSPG']"" NOTESX S TIUSPG=$S(+$G(TIUSPG):0,1:1)
DEV S %ZIS("B")=$P($G(^%ZIS(1,+$P($G(^TIU(8925.93,$P(TIULOC,U,2),1)),U,3),0),""),U) ;brings up default prter from param file
W ! S %ZIS="Q" D ^%ZIS I POP K POP G EXIT
I $E(IOST)="C" W $C(7),$C(7),!?5,"You must select a "
I W "printer for this option!!" G DEV
S $P(^TIU(8925.93,$P(TIULOC,U,2),0),U,4)=""
I $D(IO("Q")) K IO("Q") D G EXIT
.S ZTRTN="PRINT^TIUPRPN5",ZTSAVE("^TMP(""TIUPR"",$J,")=""
.S ZTSAVE("TIUSPG")="",ZTSAVE("TIULAST")="",ZTSAVE("TIULOC")=""
.S ZTDESC="TIU PRT PNS BY LOCATION"
.D ^%ZTLOAD W !,$S($D(ZTSK):"Request Queued!",1:"Request Canceled!")
.K ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,%ZIS,TIULAST,TIUSPG,TIULOC
.D HOME^%ZIS
U IO D PRINT,^%ZISC
NOTESX ;
K ^TMP("TIUREPLACE",$J)
Q
PRINT ;
K ^TMP("TIULQ",$J)
I $D(ZTQUEUED) S ZTREQ="@"
D PRINT^TIUPRPN1(1,$G(TIUSPG))
S $P(^TIU(8925.93,$P(TIULOC,U,2),1),U,2)=TIULAST
EXIT K ^TMP("TIULQ",$J),^TMP("TIUPR",$J),^TMP("TIUREPLACE",$J)
Q
;
1 W !!,"I don't seem to have any record of you having used this option "
W !,"to print progress notes for this location.",!
Q
2 W !!,"I could not determine what the last note printed for this "
W !,"location was."
W !!,"Please select a date and all notes from that date to NOW will be"
W !,"printed. The last note printed will become the new base date.",!
Q
3 W !!,"OK- then select a different date.",!
Q
HELP ; help for continue from this point prompt
W !!,"Every note that has been signed since this date (last time this"
W !,"notes were printed using this option) until NOW will be printed."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUPRPN5 4634 printed Dec 13, 2024@02:43:50 Page 2
TIUPRPN5 ;SLC/MJC-Sort PNs for Prting by Location;6/26/01
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**100,121**;Jun 20, 1997
+2 ;
LOC ;sorts PNs for prting by CLINIC location
+1 ;these notes are chartable contiguous or separate
+2 ;this option is screened to exclude WARDs
+3 ;sites should use the [TIU PRINT PN WARD] option which sorts
+4 ;by BED NUMBER for current inpts on that ward for INPT notes
+5 ;[TIU PRINT PN OUTPT LOC]
+6 ;
+7 NEW DIC,Y,TIUQT,TIULOC
+8 DO SETUP^TIUPRPN3("Print Progress Notes for OUTPATIENT LOCATION")
DIC FOR
Begin DoDot:1
+1 SET DIC=8925.93
SET DIC(0)="AEQMNZ"
SET DIC("A")="Select OUTPATIENT location: "
+2 SET DIC("S")="I $P($G(^SC(+$P($G(^TIU(8925.93,+Y,0)),U),0)),U,3)'=""W"""
+3 WRITE !
DO ^DIC
KILL DIC("S")
IF Y<0
SET TIUQT=1
QUIT
+4 SET TIULOC=+Y(0)_U_+Y_U_Y(0,0)
+5 IF '$DATA(^TIU(8925,"ALOCP",+TIULOC))
Begin DoDot:2
+6 WRITE !,$CHAR(7),"There are no signed Progress Notes for this location!!"
End DoDot:2
QUIT
+7 DO NOTES(TIULOC)
End DoDot:1
if $DATA(TIUQT)
QUIT
+8 QUIT
+9 ;
NOTES(TIULOC) ;returns date/time;ien of last note prted
+1 NEW OLD,NEW,Y,BEG,IFN,TIUSPG,CTR,TIULAST,ANS,MSG,TIUQT,DFN,SORT
+2 KILL ^TMP("TIUREPLACE",$JOB)
+3 SET MSG=1
SET TIULAST=$PIECE($GET(^TIU(8925.93,+$PIECE(TIULOC,U,2),1)),U,2)
+4 IF TIULAST]""
Begin DoDot:1
+5 IF '+$GET(TIULAST)!'$PIECE(TIULAST,";",2)!('$DATA(^TIU(8925,"ALOCP",+TIULOC,+TIULAST,+$PIECE(TIULAST,";",2))))
SET $PIECE(^TIU(8925.93,+$PIECE(TIULOC,U,2),1),U,2)=""
SET MSG=2
QUIT
+6 SET BEG=+TIULAST
+7 WRITE !!,"The last note printed for this location using this option was "
+8 WRITE !,"signed ",$$FMTE^XLFDT(BEG,"1P"),!!
+9 SET ANS=$$READ^TIUU("YA","Print from this point on? ","YES","^D HELP^TIUPRPN5")
+10 IF $DATA(DIRUT)
SET TIUQT=1
QUIT
+11 IF +$GET(ANS)
SET IFN=$PIECE(TIULAST,U,2)
QUIT
+12 SET $PIECE(^TIU(8925.93,+$PIECE(TIULOC,U,2),1),U,2)=""
SET MSG=3
End DoDot:1
if $DATA(TIUQT)
QUIT
+13 IF $PIECE($GET(^TIU(8925.93,+$PIECE(TIULOC,U,2),1)),U,2)']""
Begin DoDot:1
+14 ;writes message to explain date selection
DO @MSG
RANGE SET OLD=$ORDER(^TIU(8925,"ALOCP",+TIULOC,0))
+1 SET NEW=$ORDER(^TIU(8925,"ALOCP",+TIULOC,9999999),-1)
+2 WRITE !," The OLDEST note was signed: ",$$FMTE^XLFDT(OLD,"1P")
+3 WRITE !,"The MOST RECENT note was signed: ",$$FMTE^XLFDT(NEW,"1P"),!
+4 WRITE !,"Select a date and I will print all signed notes for "
+5 WRITE !,$PIECE(TIULOC,U,3)," from this date until NOW.",!
DATE SET %DT="AEPX"
SET %DT(0)="-NOW"
SET %DT("A")="Print Notes Beginning: "
+1 DO ^%DT
KILL %DT
IF $DATA(DTOUT)!(Y<0)
SET TIUQT=1
QUIT
+2 IF Y>NEW
WRITE $CHAR(7),!?5,"Pick a date between the OLDEST and the MOST "
+3 IF $TEST
WRITE "RECENT."
GOTO DATE
+4 SET BEG=Y
End DoDot:1
if $DATA(TIUQT)
QUIT
+5 SET CTR=0
FOR
SET BEG=$ORDER(^TIU(8925,"ALOCP",+TIULOC,BEG))
if 'BEG
QUIT
Begin DoDot:1
+6 IF '$DATA(IFN)
SET IFN=0
+7 FOR
SET IFN=$ORDER(^TIU(8925,"ALOCP",+TIULOC,BEG,IFN))
if 'IFN
QUIT
Begin DoDot:2
+8 WRITE "."
DO REPLACE^TIUPRPN3(IFN,BEG,1501)
End DoDot:2
End DoDot:1
+9 SET IFN=0
FOR
SET IFN=$ORDER(^TMP("TIUREPLACE",$JOB,IFN))
if 'IFN
QUIT
Begin DoDot:1
+10 SET DFN=$PIECE(^TIU(8925,IFN,0),U,2)
SET SORT=$PIECE(^DPT(DFN,0),U)_";"_DFN
+11 SET BEG=^TMP("TIUREPLACE",$JOB,IFN,"DT")
+12 SET ^TMP("TIUPR",$JOB,SORT,BEG,IFN)="Vice SF 509"
+13 SET TIULAST=BEG_";"_IFN
End DoDot:1
+14 SET CTR=+$GET(^TMP("TIUREPLACE",$JOB))
+15 IF CTR=0
WRITE $CHAR(7),!!,"No notes have been signed for this location since "
+16 IF $TEST
WRITE $$FMTE^XLFDT(+TIULAST,"1P")
GOTO NOTESX
+17 WRITE !,">> "_CTR_" note"_$SELECT(CTR>1:"s",1:"")_" found for "_$PIECE(TIULOC,U,3)
+18 IF CTR'>1
SET TIUSPG=1
+19 IF '$TEST
SET TIUSPG=$$PAGE^TIUPRPN3
if TIUSPG']""
GOTO NOTESX
SET TIUSPG=$SELECT(+$GET(TIUSPG):0,1:1)
DEV ;brings up default prter from param file
SET %ZIS("B")=$PIECE($GET(^%ZIS(1,+$PIECE($GET(^TIU(8925.93,$PIECE(TIULOC,U,2),1)),U,3),0),""),U)
+1 WRITE !
SET %ZIS="Q"
DO ^%ZIS
IF POP
KILL POP
GOTO EXIT
+2 IF $EXTRACT(IOST)="C"
WRITE $CHAR(7),$CHAR(7),!?5,"You must select a "
+3 IF $TEST
WRITE "printer for this option!!"
GOTO DEV
+4 SET $PIECE(^TIU(8925.93,$PIECE(TIULOC,U,2),0),U,4)=""
+5 IF $DATA(IO("Q"))
KILL IO("Q")
Begin DoDot:1
+6 SET ZTRTN="PRINT^TIUPRPN5"
SET ZTSAVE("^TMP(""TIUPR"",$J,")=""
+7 SET ZTSAVE("TIUSPG")=""
SET ZTSAVE("TIULAST")=""
SET ZTSAVE("TIULOC")=""
+8 SET ZTDESC="TIU PRT PNS BY LOCATION"
+9 DO ^%ZTLOAD
WRITE !,$SELECT($DATA(ZTSK):"Request Queued!",1:"Request Canceled!")
+10 KILL ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,%ZIS,TIULAST,TIUSPG,TIULOC
+11 DO HOME^%ZIS
End DoDot:1
GOTO EXIT
+12 USE IO
DO PRINT
DO ^%ZISC
NOTESX ;
+1 KILL ^TMP("TIUREPLACE",$JOB)
+2 QUIT
PRINT ;
+1 KILL ^TMP("TIULQ",$JOB)
+2 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 DO PRINT^TIUPRPN1(1,$GET(TIUSPG))
+4 SET $PIECE(^TIU(8925.93,$PIECE(TIULOC,U,2),1),U,2)=TIULAST
EXIT KILL ^TMP("TIULQ",$JOB),^TMP("TIUPR",$JOB),^TMP("TIUREPLACE",$JOB)
+1 QUIT
+2 ;
1 WRITE !!,"I don't seem to have any record of you having used this option "
+1 WRITE !,"to print progress notes for this location.",!
+2 QUIT
2 WRITE !!,"I could not determine what the last note printed for this "
+1 WRITE !,"location was."
+2 WRITE !!,"Please select a date and all notes from that date to NOW will be"
+3 WRITE !,"printed. The last note printed will become the new base date.",!
+4 QUIT
3 WRITE !!,"OK- then select a different date.",!
+1 QUIT
HELP ; help for continue from this point prompt
+1 WRITE !!,"Every note that has been signed since this date (last time this"
+2 WRITE !,"notes were printed using this option) until NOW will be printed."
+3 QUIT
