- PSIVPGE ;BIR/PR-PURGE IV ORDERS ;05 DEC 97 / 8:44 AM
- ;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
- ;
- EN ;
- N XQUIT D ^PSIVXU Q:$D(PSIVXU) D VW
- Q W:'$D(PSIVPR)&($Y) @IOF S:$D(ZTQUEUED) ZTREQ="@" K DFN,N,ON,P,P17,PS,PSIVDT,PSIVLAB,PSIVLOG,PSIVPN,PSIVRD,PSIVREA,PSIVPDT,PSIVVO,PSJACNWP,Z,ZTSK D ENIVKV^PSGSETU
- Q
- VW ;Ask user to view order.
- S (PSIVLOG,PSIVLAB)=0 W !!,"View orders before purged" S %=1 D YN^DICN G:%=-1 Q I %=0 S HELP="PRTVW" D ^PSIVHLP1 G VW
- S PSIVVO=%[1 I PSIVVO,PSIVPR=ION W $C(7),!!,"WARNING -- YOU HAVE NOT SELECTED A PRINTER PROFILE DEVICE !!"
- ;
- VW1 ;Ask user to view activity log.
- I PSIVVO W !,"View activity logs before purged" S %=1 D YN^DICN G:%=-1 Q S PSIVLOG=%[1 I %=0 S HELP="PRTAVW" D ^PSIVHLP1 G VW1
- ;
- VW2 ;Ask to view label log
- I PSIVVO W !,"View label logs before purged" S %=1 D YN^DICN G:%=-1 Q S PSIVLAB=%[1 I %=0 S HELP="LABLOG" D ^PSIVHLP2 G VW2
- BEG ;Start purge
- S HELP="PURGE" D ^PSIVHLP W ! S %DT="ETA",%DT("A")="Purge orders older than what date: " D ^%DT G:Y<0 Q
- S PSIVPDT=Y D NOW^%DTC S Y=% S X1=Y,X2=PSIVPDT D ^%DTC I X<30 W $C(7),!,"Enter a date greater than 30 days ago.",! G BEG
- ;
- YN ;Make sure it is ok to start purge.
- W !!,"Will purge expired IV orders from " S Y=PSIVPDT X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2),"back.",!,"Ok to start purge" S %=2 D YN^DICN I %=0 S HELP="YNPRG" D ^PSIVHLP1 G YN
- G:%=-1!(%=2) Q
- I PSIVPR'=ION S ZTDESC="PURGE IV ORDERS",ZTRTN="DEQ^PSIVPGE",(ZTSAVE("PSIVLOG"),ZTSAVE("PSIVLAB"),ZTSAVE("PSIVSITE"),ZTSAVE("PSIVPDT"),ZTSAVE("PSIVVO"),ZTSAVE("PSIVSN"),ZTSAVE("PSJSYSW0"),ZTSAVE("PSJSYSU"))="",ZTIO=PSIVPR D ^%ZTLOAD G Q
- ;
- DEQ W:$Y @IOF S PSIVPN=0,Y=PSIVPDT,PSIVSLV=IO'=IO(0)!(IOST'["C-") X ^DD("DD") W:PSIVSLV !,"Purge expired IV orders from ",$P(Y,"@")," ",$P(Y,"@",2)," back.",!,"Time started: "
- D NOW^%DTC S Y=$E(%,1,12) X ^DD("DD") W:PSIVSLV $P(Y,"@")," ",$P(Y,"@",2),!!
- S PSIVPDT=PSIVPDT+1,PSIVRD=1
- F PSIVDT=0:0 S PSIVDT=$O(^PS(55,"AIV",PSIVDT)) Q:PSIVDT>PSIVPDT!('PSIVDT)!$D(DIRUT) D
- .F DFN=0:0 S DFN=$O(^PS(55,"AIV",PSIVDT,DFN)) Q:'DFN!$D(DIRUT) D:PSIVVO&(PSIVDT>1) ENNA^PSIVACT S PSJACNWP=1 D ENIV^PSJAC F ON=0:0 S ON=$O(^PS(55,"AIV",PSIVDT,DFN,ON)) Q:'ON!$D(DIRUT) D PRGE
- I '$D(DIRUT) W !!,"Time finished: " D NOW^%DTC S Y=% X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2) W !,"Number of IV ORDERS purged is: ",PSIVPN,!!
- D Q
- Q
- PRGE ;
- I $D(^PS(55,DFN,"IV",ON,2)) I $P(^(2),"^",2)'=PSIVSN&$P(^(2),"^",2)!(^(2)>PSIVPDT&($P(^PS(55,DFN,"IV",ON,0),"^",3)'=1)) Q
- I $G(^PS(55,DFN,"IV",ON,"ADC")) S TDC=+^("ADC") K ^PS(55,"ADC",TDC,DFN,ON),TDC
- I PSIVVO,$D(^PS(55,DFN,"IV",ON,0)),PSIVDT>1 S (P("PON"),ON55)=ON_"V" D GT55^PSIVORFB,ENNONUM^PSIVORV2(DFN,ON) S PSIVPN=PSIVPN+1 D PAUSE Q:$D(DIRUT)
- I 'PSIVVO,$D(^PS(55,DFN,"IV",ON,0)),PSIVDT>1 S PSIVPN=PSIVPN+1 W:'(PSIVPN#100) "."
- I PSIVLOG,$D(^PS(55,DFN,"IV",ON,0)),PSIVDT>1 S PSJORD=ON55 D ENLOG^PSIVVW1,PAUSE Q:$D(DIRUT)
- S ON=+ON ;* ^PSIVVW1 set ON=PSJORD and PSJORD is concatenated to "V"
- I PSIVLAB,$D(^PS(55,DFN,"IV",ON,0)),PSIVDT>1 D DATA^PSIVLTR1(DFN,ON),PAUSE Q:$D(DIRUT)
- D DCNV^PSIVOE S X=$G(^PS(55,DFN,"IV",ON,0)) Q:'X
- K ^PS(55,"PSIVSUS",PSIVSN,DFN,ON),^PS(55,"AIV",PSIVDT,DFN,ON),^PS(55,DFN,"IV",ON),^PS(55,DFN,"IV","B",ON)
- K:$D(^PS(55,DFN,"IV","AIT",$P(X,U,4),$P(X,U,3),ON)) ^PS(55,DFN,"IV","AIT",$P(X,U,4),$P(X,U,3),ON)
- K:$D(^PS(55,DFN,"IV","AIS",$P(X,U,3),ON)) ^PS(55,DFN,"IV","AIS",$P(X,U,3),ON)
- I $D(^PS(55,DFN,"IV",0)),$P(^(0),"^",4) S $P(^(0),"^",4)=$P(^(0),"^",4)-1
- Q
- ;
- PAUSE ;
- I 'PSIVSLV K DIR S DIR(0)="E" D ^DIR
- Q
- ;
- ENT ;Will let user delete an IV order if no doses printed.
- D FULL^VALM1
- S PSJORD=ON D ENNH^PSIVORV2(ON)
- D A,PAUSE^PSJLMUTL
- Q
- A W !,"Delete this order" S %=2 D YN^DICN I %=0 S HELP="OPUR" D ^PSIVHLP1 G A
- I %=-1!(%=2) W $C(7)," Order not deleted." Q
- S ON=+ON55 I $D(^PS(55,DFN,"IV",ON,9)) S Y=^(9) I $P(Y,"^",2) W !,"Order # ",ON," ... Not deleted ",$P(Y,"^",2)," dose(s) given " S Y=+Y X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2) Q
- D ENDEL W " Order deleted." Q
- ENDEL ;D DCNV^PSIVOE S X=^PS(55,DFN,"IV",ON,0) S $P(X,U,17)="P" K:$P(X,U,3)]"" ^PS(55,"AIV",$P(X,U,3),DFN,ON) S $P(X,U,3)=1,^PS(55,DFN,"IV",ON,0)=X,^PS(55,"AIV",1,DFN,ON)="" I $D(^PS(55,DFN,"IV",ON,"ADC")) S TC=^("ADC") K ^PS(55,"ADC",TC,DFN,ON)
- D DCNV^PSIVOE S X=$G(^PS(55,DFN,"IV",ON,0)) Q:'X S $P(X,U,17)="P"
- K:$P(X,U,3)]"" ^PS(55,"AIV",$P(X,U,3),DFN,ON)
- K:$D(^PS(55,DFN,"IV","AIT",$P(X,U,4),$P(X,U,3),ON)) ^PS(55,DFN,"IV","AIT",$P(X,U,4),$P(X,U,3),ON)
- K:$D(^PS(55,DFN,"IV","AIS",$P(X,U,3),ON)) ^PS(55,DFN,"IV","AIS",$P(X,U,3),ON)
- S $P(X,U,3)=1,^PS(55,DFN,"IV",ON,0)=X,^PS(55,"AIV",1,DFN,ON)="",^PS(55,DFN,"IV","AIT",$P(X,U,4),1,ON)="",^PS(55,DFN,"IV","AIS",1,ON)=""
- I $D(^PS(55,DFN,"IV",ON,"ADC")) S TC=^("ADC") K ^PS(55,"ADC",TC,DFN,ON)
- PSIVPGE ;BIR/PR-PURGE IV ORDERS ;05 DEC 97 / 8:44 AM
- +1 ;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
- +2 ;
- EN ;
- +1 NEW XQUIT
- DO ^PSIVXU
- IF $DATA(PSIVXU)
- QUIT
- DO VW
- Q IF '$DATA(PSIVPR)&($Y)
- WRITE @IOF
- IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- KILL DFN,N,ON,P,P17,PS,PSIVDT,PSIVLAB,PSIVLOG,PSIVPN,PSIVRD,PSIVREA,PSIVPDT,PSIVVO,PSJACNWP,Z,ZTSK
- DO ENIVKV^PSGSETU
- +1 QUIT
- VW ;Ask user to view order.
- +1 SET (PSIVLOG,PSIVLAB)=0
- WRITE !!,"View orders before purged"
- SET %=1
- DO YN^DICN
- IF %=-1
- GOTO Q
- IF %=0
- SET HELP="PRTVW"
- DO ^PSIVHLP1
- GOTO VW
- +2 SET PSIVVO=%[1
- IF PSIVVO
- IF PSIVPR=ION
- WRITE $CHAR(7),!!,"WARNING -- YOU HAVE NOT SELECTED A PRINTER PROFILE DEVICE !!"
- +3 ;
- VW1 ;Ask user to view activity log.
- +1 IF PSIVVO
- WRITE !,"View activity logs before purged"
- SET %=1
- DO YN^DICN
- IF %=-1
- GOTO Q
- SET PSIVLOG=%[1
- IF %=0
- SET HELP="PRTAVW"
- DO ^PSIVHLP1
- GOTO VW1
- +2 ;
- VW2 ;Ask to view label log
- +1 IF PSIVVO
- WRITE !,"View label logs before purged"
- SET %=1
- DO YN^DICN
- IF %=-1
- GOTO Q
- SET PSIVLAB=%[1
- IF %=0
- SET HELP="LABLOG"
- DO ^PSIVHLP2
- GOTO VW2
- BEG ;Start purge
- +1 SET HELP="PURGE"
- DO ^PSIVHLP
- WRITE !
- SET %DT="ETA"
- SET %DT("A")="Purge orders older than what date: "
- DO ^%DT
- IF Y<0
- GOTO Q
- +2 SET PSIVPDT=Y
- DO NOW^%DTC
- SET Y=%
- SET X1=Y
- SET X2=PSIVPDT
- DO ^%DTC
- IF X<30
- WRITE $CHAR(7),!,"Enter a date greater than 30 days ago.",!
- GOTO BEG
- +3 ;
- YN ;Make sure it is ok to start purge.
- +1 WRITE !!,"Will purge expired IV orders from "
- SET Y=PSIVPDT
- XECUTE ^DD("DD")
- WRITE $PIECE(Y,"@")," ",$PIECE(Y,"@",2),"back.",!,"Ok to start purge"
- SET %=2
- DO YN^DICN
- IF %=0
- SET HELP="YNPRG"
- DO ^PSIVHLP1
- GOTO YN
- +2 IF %=-1!(%=2)
- GOTO Q
- +3 IF PSIVPR'=ION
- SET ZTDESC="PURGE IV ORDERS"
- SET ZTRTN="DEQ^PSIVPGE"
- SET (ZTSAVE("PSIVLOG"),ZTSAVE("PSIVLAB"),ZTSAVE("PSIVSITE"),ZTSAVE("PSIVPDT"),ZTSAVE("PSIVVO"),ZTSAVE("PSIVSN"),ZTSAVE("PSJSYSW0"),ZTSAVE("PSJSYSU"))=""
- SET ZTIO=PSIVPR
- DO ^%ZTLOAD
- GOTO Q
- +4 ;
- DEQ IF $Y
- WRITE @IOF
- SET PSIVPN=0
- SET Y=PSIVPDT
- SET PSIVSLV=IO'=IO(0)!(IOST'["C-")
- XECUTE ^DD("DD")
- IF PSIVSLV
- WRITE !,"Purge expired IV orders from ",$PIECE(Y,"@")," ",$PIECE(Y,"@",2)," back.",!,"Time started: "
- +1 DO NOW^%DTC
- SET Y=$EXTRACT(%,1,12)
- XECUTE ^DD("DD")
- IF PSIVSLV
- WRITE $PIECE(Y,"@")," ",$PIECE(Y,"@",2),!!
- +2 SET PSIVPDT=PSIVPDT+1
- SET PSIVRD=1
- +3 FOR PSIVDT=0:0
- SET PSIVDT=$ORDER(^PS(55,"AIV",PSIVDT))
- IF PSIVDT>PSIVPDT!('PSIVDT)!$DATA(DIRUT)
- QUIT
- Begin DoDot:1
- +4 FOR DFN=0:0
- SET DFN=$ORDER(^PS(55,"AIV",PSIVDT,DFN))
- IF 'DFN!$DATA(DIRUT)
- QUIT
- IF PSIVVO&(PSIVDT>1)
- DO ENNA^PSIVACT
- SET PSJACNWP=1
- DO ENIV^PSJAC
- FOR ON=0:0
- SET ON=$ORDER(^PS(55,"AIV",PSIVDT,DFN,ON))
- IF 'ON!$DATA(DIRUT)
- QUIT
- DO PRGE
- End DoDot:1
- +5 IF '$DATA(DIRUT)
- WRITE !!,"Time finished: "
- DO NOW^%DTC
- SET Y=%
- XECUTE ^DD("DD")
- WRITE $PIECE(Y,"@")," ",$PIECE(Y,"@",2)
- WRITE !,"Number of IV ORDERS purged is: ",PSIVPN,!!
- +6 DO Q
- +7 QUIT
- PRGE ;
- +1 IF $DATA(^PS(55,DFN,"IV",ON,2))
- IF $PIECE(^(2),"^",2)'=PSIVSN&$PIECE(^(2),"^",2)!(^(2)>PSIVPDT&($PIECE(^PS(55,DFN,"IV",ON,0),"^",3)'=1))
- QUIT
- +2 IF $GET(^PS(55,DFN,"IV",ON,"ADC"))
- SET TDC=+^("ADC")
- KILL ^PS(55,"ADC",TDC,DFN,ON),TDC
- +3 IF PSIVVO
- IF $DATA(^PS(55,DFN,"IV",ON,0))
- IF PSIVDT>1
- SET (P("PON"),ON55)=ON_"V"
- DO GT55^PSIVORFB
- DO ENNONUM^PSIVORV2(DFN,ON)
- SET PSIVPN=PSIVPN+1
- DO PAUSE
- IF $DATA(DIRUT)
- QUIT
- +4 IF 'PSIVVO
- IF $DATA(^PS(55,DFN,"IV",ON,0))
- IF PSIVDT>1
- SET PSIVPN=PSIVPN+1
- IF '(PSIVPN#100)
- WRITE "."
- +5 IF PSIVLOG
- IF $DATA(^PS(55,DFN,"IV",ON,0))
- IF PSIVDT>1
- SET PSJORD=ON55
- DO ENLOG^PSIVVW1
- DO PAUSE
- IF $DATA(DIRUT)
- QUIT
- +6 ;* ^PSIVVW1 set ON=PSJORD and PSJORD is concatenated to "V"
- SET ON=+ON
- +7 IF PSIVLAB
- IF $DATA(^PS(55,DFN,"IV",ON,0))
- IF PSIVDT>1
- DO DATA^PSIVLTR1(DFN,ON)
- DO PAUSE
- IF $DATA(DIRUT)
- QUIT
- +8 DO DCNV^PSIVOE
- SET X=$GET(^PS(55,DFN,"IV",ON,0))
- IF 'X
- QUIT
- +9 KILL ^PS(55,"PSIVSUS",PSIVSN,DFN,ON),^PS(55,"AIV",PSIVDT,DFN,ON),^PS(55,DFN,"IV",ON),^PS(55,DFN,"IV","B",ON)
- +10 IF $DATA(^PS(55,DFN,"IV","AIT",$PIECE(X,U,4),$PIECE(X,U,3),ON))
- KILL ^PS(55,DFN,"IV","AIT",$PIECE(X,U,4),$PIECE(X,U,3),ON)
- +11 IF $DATA(^PS(55,DFN,"IV","AIS",$PIECE(X,U,3),ON))
- KILL ^PS(55,DFN,"IV","AIS",$PIECE(X,U,3),ON)
- +12 IF $DATA(^PS(55,DFN,"IV",0))
- IF $PIECE(^(0),"^",4)
- SET $PIECE(^(0),"^",4)=$PIECE(^(0),"^",4)-1
- +13 QUIT
- +14 ;
- PAUSE ;
- +1 IF 'PSIVSLV
- KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- +2 QUIT
- +3 ;
- ENT ;Will let user delete an IV order if no doses printed.
- +1 DO FULL^VALM1
- +2 SET PSJORD=ON
- DO ENNH^PSIVORV2(ON)
- +3 DO A
- DO PAUSE^PSJLMUTL
- +4 QUIT
- A WRITE !,"Delete this order"
- SET %=2
- DO YN^DICN
- IF %=0
- SET HELP="OPUR"
- DO ^PSIVHLP1
- GOTO A
- +1 IF %=-1!(%=2)
- WRITE $CHAR(7)," Order not deleted."
- QUIT
- +2 SET ON=+ON55
- IF $DATA(^PS(55,DFN,"IV",ON,9))
- SET Y=^(9)
- IF $PIECE(Y,"^",2)
- WRITE !,"Order # ",ON," ... Not deleted ",$PIECE(Y,"^",2)," dose(s) given "
- SET Y=+Y
- XECUTE ^DD("DD")
- WRITE $PIECE(Y,"@")," ",$PIECE(Y,"@",2)
- QUIT
- +3 DO ENDEL
- WRITE " Order deleted."
- QUIT
- ENDEL ;D DCNV^PSIVOE S X=^PS(55,DFN,"IV",ON,0) S $P(X,U,17)="P" K:$P(X,U,3)]"" ^PS(55,"AIV",$P(X,U,3),DFN,ON) S $P(X,U,3)=1,^PS(55,DFN,"IV",ON,0)=X,^PS(55,"AIV",1,DFN,ON)="" I $D(^PS(55,DFN,"IV",ON,"ADC")) S TC=^("ADC") K ^PS(55,"ADC",TC,DFN,ON)
- +1 DO DCNV^PSIVOE
- SET X=$GET(^PS(55,DFN,"IV",ON,0))
- IF 'X
- QUIT
- SET $PIECE(X,U,17)="P"
- +2 IF $PIECE(X,U,3)]""
- KILL ^PS(55,"AIV",$PIECE(X,U,3),DFN,ON)
- +3 IF $DATA(^PS(55,DFN,"IV","AIT",$PIECE(X,U,4),$PIECE(X,U,3),ON))
- KILL ^PS(55,DFN,"IV","AIT",$PIECE(X,U,4),$PIECE(X,U,3),ON)
- +4 IF $DATA(^PS(55,DFN,"IV","AIS",$PIECE(X,U,3),ON))
- KILL ^PS(55,DFN,"IV","AIS",$PIECE(X,U,3),ON)
- +5 SET $PIECE(X,U,3)=1
- SET ^PS(55,DFN,"IV",ON,0)=X
- SET ^PS(55,"AIV",1,DFN,ON)=""
- SET ^PS(55,DFN,"IV","AIT",$PIECE(X,U,4),1,ON)=""
- SET ^PS(55,DFN,"IV","AIS",1,ON)=""
- +6 IF $DATA(^PS(55,DFN,"IV",ON,"ADC"))
- SET TC=^("ADC")
- KILL ^PS(55,"ADC",TC,DFN,ON)
