TIUPRPN4 ;SLC/MJC;Print Progress Notes for Inpt Location; 6/26/01
;;1.0;TEXT INTEGRATION UTILITIES;**25,100,121**;Jun 20, 1997
;
LOC ;sorts PNs for prting by WARD location
;this option is for inpts
;it prts all PNs for a selected date range for all patients
;currently on the WARD
;these notes are chartable contiguous or separate
;[TIU PRINT PN WARD]
;
N DIC,Y,TIUQT,TIULOC,WARD
D SETUP^TIUPRPN3("Print Progress Notes for ALL patients on WARD")
DIC F D Q:$D(TIUQT)
.S DIC=8925.93,DIC(0)="AEQMNZ",DIC("A")="Select WARD 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 I Y<0 S TIUQT=1 Q
.S WARD=Y(0,0)
.I '+$O(^DIC(42,"B",WARD,0)) D
..S WARD=$P($G(^DIC(42,+$G(^SC(+$P(Y,U,2),42)),0)),U)
.I '+$O(^DIC(42,"B",WARD,0)) D Q
..S TIUQT=1
..W !!,"Invalid WARD LOCATION...Contact IRM."
.S TIULOC=+Y(0)_U_+Y_U_Y(0,0)
.;ien hosp loc^ien tiu prt param^external ward loc
.D NOTES(TIULOC)
Q
;
NOTES(TIULOC) ;sets date/time of when notes prted
N Y,BEG,MOVE,BED,DATE,CTR,TIULAST,ANS,IFN,TIUSPG,DFN,TIUQT
K ^TMP("TIUREPLACE",$J)
S TIULAST=$P($G(^TIU(8925.93,+$P(TIULOC,U,2),1)),U,2)
I TIULAST']"" S BEG=$$DATE() Q:BEG']""
I TIULAST]"" D Q:$D(TIUQT)
.I '+$G(TIULAST) D 2^TIUPRPN5 S BEG=$$DATE() I BEG']"" S TIUQT=1 Q
.W !!,"Notes were last printed for "_WARD_" at "
.W $$FMTE^XLFDT(+TIULAST,"1P"),!
.S ANS=$$READ^TIUU("YA","Print from this DATE/TIME on? ","YES","^D HELP^TIUPRPN5")
.I $D(DIRUT) S TIUQT=1 Q
.I +$G(ANS) S BEG=+TIULAST Q
.D 3^TIUPRPN5 S BEG=$$DATE() I BEG']"" S TIUQT=1 Q
S TIULAST=BEG
S MOVE=0 F S MOVE=$O(^DGPM("CN",WARD,MOVE)) Q:'MOVE D
.Q:'$D(^DGPM(MOVE,0))
.S DFN=$P(^DGPM(MOVE,0),U,3)
.S BEG=$E(TIULAST,1,12)-.0001 ;back up one minute
.F S BEG=$O(^TIU(8925,"APTP",DFN,BEG)) Q:'BEG D
..S IFN=0 F S IFN=$O(^TIU(8925,"APTP",DFN,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),BED=$G(^DPT(DFN,.101))_" "
.S BEG=^TMP("TIUREPLACE",$J,IFN,"DT")
.S ^TMP("TIUPR",$J,BED_";"_DFN,BEG,IFN)="Vice SF 509"
S CTR=+$G(^TMP("TIUREPLACE",$J))
I CTR=0 W $C(7),!!,"No notes have been signed for "_WARD_" since "
I W $$FMTE^XLFDT(TIULAST,"1P") G NOTESX
W !,">> "_CTR_" note"_$S(CTR>1:"s",1:"")_" found for WARD "_WARD
S TIUSPG=1,TIULAST=$$NOW^XLFDT
D DEV^TIUPRPN5
NOTESX ;
K ^TMP("TIUREPLACE",$J)
Q
DATE() W ! S %DT="AESTPX",%DT(0)="-NOW"
S %DT("A")="Print Notes Starting With (DATE/TIME): "
D ^%DT K %DT
S BEG=$S($D(DTOUT):"",Y<0:"",1:Y)
Q BEG
;
ADD ; enter/edit locations in file 8925.93
N DA,DIC,DIE,DR,TIUQT,Y
F W ! D Q:$D(TIUQT)
.S (DIC,DLAYGO)=8925.93,DIC(0)="AEQMNL"
.S DIC("A")="Select Clinic or Ward: "
.D ^DIC I Y<0 S TIUQT=1 Q
.S DIE=DIC,DA=+Y,DR="1.03;3" D ^DIE
K DLAYGO
Q
;
DIV ; enter/edit division params in file 8925.94
N DA,DIC,DIE,DR,TIUQT,Y
F W ! D Q:$D(TIUQT)
.S (DIC,DLAYGO)=8925.94,DIC(0)="AEQMNL"
.S DIC("A")="Select Division for PNs Outpatient Batch Print: "
.D ^DIC I Y<0 S TIUQT=1 Q
.S DIE=DIC,DA=+Y,DR=".02;1.02" D ^DIE
K DLAYGO
Q
TIUPRPN4 ;SLC/MJC;Print Progress Notes for Inpt Location; 6/26/01
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**25,100,121**;Jun 20, 1997
+2 ;
LOC ;sorts PNs for prting by WARD location
+1 ;this option is for inpts
+2 ;it prts all PNs for a selected date range for all patients
+3 ;currently on the WARD
+4 ;these notes are chartable contiguous or separate
+5 ;[TIU PRINT PN WARD]
+6 ;
+7 NEW DIC,Y,TIUQT,TIULOC,WARD
+8 DO SETUP^TIUPRPN3("Print Progress Notes for ALL patients on WARD")
DIC FOR
Begin DoDot:1
+1 SET DIC=8925.93
SET DIC(0)="AEQMNZ"
SET DIC("A")="Select WARD 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
IF Y<0
SET TIUQT=1
QUIT
+4 SET WARD=Y(0,0)
+5 IF '+$ORDER(^DIC(42,"B",WARD,0))
Begin DoDot:2
+6 SET WARD=$PIECE($GET(^DIC(42,+$GET(^SC(+$PIECE(Y,U,2),42)),0)),U)
End DoDot:2
+7 IF '+$ORDER(^DIC(42,"B",WARD,0))
Begin DoDot:2
+8 SET TIUQT=1
+9 WRITE !!,"Invalid WARD LOCATION...Contact IRM."
End DoDot:2
QUIT
+10 SET TIULOC=+Y(0)_U_+Y_U_Y(0,0)
+11 ;ien hosp loc^ien tiu prt param^external ward loc
+12 DO NOTES(TIULOC)
End DoDot:1
IF $DATA(TIUQT)
QUIT
+13 QUIT
+14 ;
NOTES(TIULOC) ;sets date/time of when notes prted
+1 NEW Y,BEG,MOVE,BED,DATE,CTR,TIULAST,ANS,IFN,TIUSPG,DFN,TIUQT
+2 KILL ^TMP("TIUREPLACE",$JOB)
+3 SET TIULAST=$PIECE($GET(^TIU(8925.93,+$PIECE(TIULOC,U,2),1)),U,2)
+4 IF TIULAST']""
SET BEG=$$DATE()
IF BEG']""
QUIT
+5 IF TIULAST]""
Begin DoDot:1
+6 IF '+$GET(TIULAST)
DO 2^TIUPRPN5
SET BEG=$$DATE()
IF BEG']""
SET TIUQT=1
QUIT
+7 WRITE !!,"Notes were last printed for "_WARD_" at "
+8 WRITE $$FMTE^XLFDT(+TIULAST,"1P"),!
+9 SET ANS=$$READ^TIUU("YA","Print from this DATE/TIME on? ","YES","^D HELP^TIUPRPN5")
+10 IF $DATA(DIRUT)
SET TIUQT=1
QUIT
+11 IF +$GET(ANS)
SET BEG=+TIULAST
QUIT
+12 DO 3^TIUPRPN5
SET BEG=$$DATE()
IF BEG']""
SET TIUQT=1
QUIT
End DoDot:1
IF $DATA(TIUQT)
QUIT
+13 SET TIULAST=BEG
+14 SET MOVE=0
FOR
SET MOVE=$ORDER(^DGPM("CN",WARD,MOVE))
IF 'MOVE
QUIT
Begin DoDot:1
+15 IF '$DATA(^DGPM(MOVE,0))
QUIT
+16 SET DFN=$PIECE(^DGPM(MOVE,0),U,3)
+17 ;back up one minute
SET BEG=$EXTRACT(TIULAST,1,12)-.0001
+18 FOR
SET BEG=$ORDER(^TIU(8925,"APTP",DFN,BEG))
IF 'BEG
QUIT
Begin DoDot:2
+19 SET IFN=0
FOR
SET IFN=$ORDER(^TIU(8925,"APTP",DFN,BEG,IFN))
IF 'IFN
QUIT
Begin DoDot:3
+20 WRITE "."
DO REPLACE^TIUPRPN3(IFN,BEG,1501)
End DoDot:3
End DoDot:2
End DoDot:1
+21 SET IFN=0
FOR
SET IFN=$ORDER(^TMP("TIUREPLACE",$JOB,IFN))
IF 'IFN
QUIT
Begin DoDot:1
+22 SET DFN=$PIECE(^TIU(8925,IFN,0),U,2)
SET BED=$GET(^DPT(DFN,.101))_" "
+23 SET BEG=^TMP("TIUREPLACE",$JOB,IFN,"DT")
+24 SET ^TMP("TIUPR",$JOB,BED_";"_DFN,BEG,IFN)="Vice SF 509"
End DoDot:1
+25 SET CTR=+$GET(^TMP("TIUREPLACE",$JOB))
+26 IF CTR=0
WRITE $CHAR(7),!!,"No notes have been signed for "_WARD_" since "
+27 IF $TEST
WRITE $$FMTE^XLFDT(TIULAST,"1P")
GOTO NOTESX
+28 WRITE !,">> "_CTR_" note"_$SELECT(CTR>1:"s",1:"")_" found for WARD "_WARD
+29 SET TIUSPG=1
SET TIULAST=$$NOW^XLFDT
+30 DO DEV^TIUPRPN5
NOTESX ;
+1 KILL ^TMP("TIUREPLACE",$JOB)
+2 QUIT
DATE() WRITE !
SET %DT="AESTPX"
SET %DT(0)="-NOW"
+1 SET %DT("A")="Print Notes Starting With (DATE/TIME): "
+2 DO ^%DT
KILL %DT
+3 SET BEG=$SELECT($DATA(DTOUT):"",Y<0:"",1:Y)
+4 QUIT BEG
+5 ;
ADD ; enter/edit locations in file 8925.93
+1 NEW DA,DIC,DIE,DR,TIUQT,Y
+2 FOR
WRITE !
Begin DoDot:1
+3 SET (DIC,DLAYGO)=8925.93
SET DIC(0)="AEQMNL"
+4 SET DIC("A")="Select Clinic or Ward: "
+5 DO ^DIC
IF Y<0
SET TIUQT=1
QUIT
+6 SET DIE=DIC
SET DA=+Y
SET DR="1.03;3"
DO ^DIE
End DoDot:1
IF $DATA(TIUQT)
QUIT
+7 KILL DLAYGO
+8 QUIT
+9 ;
DIV ; enter/edit division params in file 8925.94
+1 NEW DA,DIC,DIE,DR,TIUQT,Y
+2 FOR
WRITE !
Begin DoDot:1
+3 SET (DIC,DLAYGO)=8925.94
SET DIC(0)="AEQMNL"
+4 SET DIC("A")="Select Division for PNs Outpatient Batch Print: "
+5 DO ^DIC
IF Y<0
SET TIUQT=1
QUIT
+6 SET DIE=DIC
SET DA=+Y
SET DR=".02;1.02"
DO ^DIE
End DoDot:1
IF $DATA(TIUQT)
QUIT
+7 KILL DLAYGO
+8 QUIT
