PSGPO ;BIR/CML3-PURGE PATIENT'S ORDERS ; 15 May 98 / 10:42 AM
;;5.0; INPATIENT MEDICATIONS ;**3**;16 DEC 97
D ENCV^PSGSETU Q:$D(XQUIT) S POD=$O(^PS(55,"AUDDD",0)) I 'POD K POD W !!,"THERE ARE NO ORDERS TO PURGE AT THIS TIME." Q
S EDATE=4000000 D:$S($D(^PS(53.5,"AB")):1,1:$D(^("AF"))) EDATE I EDATE<4000000 S X1=EDATE\1,X2=-31 D C^%DTC S EDATE=X I POD>EDATE W !!,"THERE ARE PICK LISTS THAT NEED TO BE FILED AWAY THAT MAY CONTAIN THESE ORDERS.",! G DONE
S PSGOD=$$ENDTC^PSGMI(POD),Y=-1
F K %DT S %DT="EPTX" S:EDATE<4000000 %DT(0)=-EDATE R !!,"PURGE ORDERS FOR PATIENTS DISCHARGED BEFORE WHAT DATE: ",X:DTIME W:'$T $C(7) S:'$T X="^" D DTM:X?1."?",^%DT:"^"'[X I Y>0!("^"[X) W:Y'>0 !,"No date chosen for order purge.",! Q
G:Y'>0 DONE W !!,"This purge will automatically be queued." K %ZIS,IO("Q"),IOP S PSGION=ION,%ZIS="NQ",%ZIS("B")="",%ZIS("A")="Please select a DEVICE for the PURGE REPORT: " D ^%ZIS
I POP S IOP=PSGION D ^%ZIS W !?3,"No device selected for purge run." G DONE
S PSGPOD=Y,PSGPOIO=ION K ZTSAVE S ZTDESC="PATIENT ORDER PURGE",PSGTIR="ENQ^PSGPO",(ZTIO,ZTSAVE("PSGPOIO"),ZTSAVE("PSGPOD"))="" D ENTSK^PSGTI W:$D(ZTSK) !,"Purge queued. (It may take a while to run.)",! G DONE
;
ENQ ;
F L +^PS(53.43,1,1,0):0 I S ND=$G(^PS(53.43,1,1,0)) S:ND="" ND="^53.4301A" Q
F RDA=$P(ND,"^",3)+1:1 W "." I '$D(^PS(53.43,1,1,RDA)) S ^PS(53.43,1,1,RDA,0)=RDA,$P(ND,"^",3)=RDA,$P(ND,"^",4)=$P(ND,"^",4)+1,^PS(53.43,1,1,0)=ND Q
L -^PS(53.43,1,1,0)
F PSGPO=0:0 S PSGPO=$O(^PS(55,"AUDDD",PSGPO)) Q:'PSGPO!(PSGPO'<PSGPOD) F DA(1)=0:0 S DA(1)=$O(^PS(55,"AUDDD",PSGPO,DA(1))) Q:'DA(1) F DA=0:0 S DA=$O(^PS(55,"AUDDD",PSGPO,DA(1),DA)) Q:'DA D:"DE"[$P(^PS(55,DA(1),5,DA,0),"^",9) DIK
K %ZIS,ZTSAVE S H=ZTSK,IOP=PSGPOIO,%ZIS="NQ",PSGJ=RDA,PSGTIR="^PSGPOR",ZTDESC="PATIENT ORDER PURGE REPORT",PSGTID=$H,(ZTSAVE("PSGPOD"),ZTSAVE("PSGJ"))="" D ^%ZIS,ENTSK^PSGTI S ZTSK=H
;
DONE ;
D ENKV^PSGSETU K AM,EDATE,H,POD,PSGJ,PSGPO,PSGPOD,PSGPOIO,ST,TRTN,ZTOUT Q
;
DIK ;
S DIK="^PS(55,"_DA(1)_",5," D ^DIK K ^PS(55,DA(1),5,"B",DA,DA),^PS(55,"AUDDD",PSGPO,DA(1),DA),^PS(55,"AUE",DA(1),DA) S ^(0)=DA(1)_"^"_$S($D(^PS(53.43,1,1,RDA,1,DA(1),0)):$P(^(0),"^",2)+1,1:1) Q
;
DTM ;
W !!," If a date is entered here, all orders for patients discharged before the date entered will be purged (deleted) from the computer. Please note that any orders for any patients admitted after the date entered will NOT be affected."
W !," The earliest discharge date found is ",PSGOD,! Q
;
EDATE ;
F X=0:0 S X=$O(^PS(53.5,"AB",X)) Q:'X S Y=$O(^(X,0)) I Y,Y<EDATE S EDATE=Y
F X=0:0 S X=$O(^PS(53.5,"AF",X)) Q:'X I $D(^PS(53.5,X,0)) S Y=$P(^(0),"^",3) I Y,Y<EDATE S EDATE=Y
Q
;
ENRX ; re-index 55 to be able to purge UD orders (AUDDD x-ref)
K ^PS(55,"AUDDD") D NOW^%DTC F P=0:0 S P=$O(^PS(55,P)) Q:'P I $D(^(P,5)) D RX1
K A Q
;
RX1 ;
F ON=0:0 S ON=$O(^PS(55,P,5,ON)) Q:'ON S:$P($G(^(+ON,0)),U,20) ^PS(55,"AUDDD",$P(^(0),U,20),P,+ON)=""
Q
;S (D1,DL)=0,X=$O(^DGPM("ATID3",P,"")) I X S X=$O(^(+X,0)) I X S X=$G(^DGPM(X,0)),D2=+X,AD=+$G(^DGPM(+$P(X,U,14),0)) S:'D2 DL=AD I D2>+D1 S D1=D2
;S (D1,DL)=0 F Q=0:0 S Q=$O(^DPT(P,"DA",Q)) Q:'Q S AD=$S($D(^(Q,0)):+^(0),1:0),D2=$S($D(^(1)):+^(1),1:0) S:'D2 DL=AD I D2>+D1 S D1=D2_"^"_Q_"^"_AD
Q:'D1 D NOW^%DTC S:'DL DL=% F Q=0:0 S Q=$O(^PS(55,P,5,"AUS",Q)) Q:'Q Q:Q>DL F QQ=0:0 S QQ=$O(^PS(55,P,5,"AUS",Q,QQ)) Q:'QQ S $P(^PS(55,P,5,QQ,0),"^",20)=+D1,^PS(55,"AUDDD",+D1,P,QQ)=""
S:$D(^PS(55,"AUDDD",+D1,P)) ^(P)=$P(D1,"^",2,3) Q
;
ENDS ; delete single order
F R !!,"DO YOU WANT TO DISCONTINUE THIS ORDER" S %=1 D YN^DICN Q:% W !!?2,"Answer 'Y' to d/c this order now. (It will be deleted immediately.)",!,"Answer 'N' (or '^') to not d/c the order."
I %=1 D
.;N DA,DIK,PSGPO I $P($G(^PS(55,PSGP,5,+PSGORD,0)),U,21) S X=$O(^ORD(101,"B","PS EVSEND OR",0))_";ORD(101,",PSJORDER=$$ORDER^PSJHLU(PSGORD),PSOC="OD",PSREASON="ORDER DISCONTINUED" D EN1^XQOR:X K X W !?3,"...one moment, please..."
.N DA,DIK,PSGPO I $P($G(^PS(55,PSGP,5,+PSGORD,0)),U,21) D EN1^PSJHL2(PSGP,"OD",PSGORD,"ORDER DISCONTINUED") W !?3,"...one moment, please..."
.S PSGCANFL=1,DA(1)=PSGP,DA=+PSGORD,DIK="^PS(55,"_PSGP_",5,",PSGPO=1 D ^DIK W ".DONE!"
K %,%Y Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGPO 4221 printed Dec 13, 2024@02:03 Page 2
PSGPO ;BIR/CML3-PURGE PATIENT'S ORDERS ; 15 May 98 / 10:42 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;**3**;16 DEC 97
+2 DO ENCV^PSGSETU
if $DATA(XQUIT)
QUIT
SET POD=$ORDER(^PS(55,"AUDDD",0))
IF 'POD
KILL POD
WRITE !!,"THERE ARE NO ORDERS TO PURGE AT THIS TIME."
QUIT
+3 SET EDATE=4000000
if $SELECT($DATA(^PS(53.5,"AB"))
DO EDATE
IF EDATE<4000000
SET X1=EDATE\1
SET X2=-31
DO C^%DTC
SET EDATE=X
IF POD>EDATE
WRITE !!,"THERE ARE PICK LISTS THAT NEED TO BE FILED AWAY THAT MAY CONTAIN THESE ORDERS.",!
GOTO DONE
+4 SET PSGOD=$$ENDTC^PSGMI(POD)
SET Y=-1
+5 FOR
KILL %DT
SET %DT="EPTX"
if EDATE<4000000
SET %DT(0)=-EDATE
READ !!,"PURGE ORDERS FOR PATIENTS DISCHARGED BEFORE WHAT DATE: ",X:DTIME
if '$TEST
WRITE $CHAR(7)
if '$TEST
SET X="^"
if X?1."?"
DO DTM
if "^"'[X
DO ^%DT
IF Y>0!("^"[X)
if Y'>0
WRITE !,"No date chosen for order purge.",!
QUIT
+6 if Y'>0
GOTO DONE
WRITE !!,"This purge will automatically be queued."
KILL %ZIS,IO("Q"),IOP
SET PSGION=ION
SET %ZIS="NQ"
SET %ZIS("B")=""
SET %ZIS("A")="Please select a DEVICE for the PURGE REPORT: "
DO ^%ZIS
+7 IF POP
SET IOP=PSGION
DO ^%ZIS
WRITE !?3,"No device selected for purge run."
GOTO DONE
+8 SET PSGPOD=Y
SET PSGPOIO=ION
KILL ZTSAVE
SET ZTDESC="PATIENT ORDER PURGE"
SET PSGTIR="ENQ^PSGPO"
SET (ZTIO,ZTSAVE("PSGPOIO"),ZTSAVE("PSGPOD"))=""
DO ENTSK^PSGTI
if $DATA(ZTSK)
WRITE !,"Purge queued. (It may take a while to run.)",!
GOTO DONE
+9 ;
ENQ ;
+1 FOR
LOCK +^PS(53.43,1,1,0):0
IF $TEST
SET ND=$GET(^PS(53.43,1,1,0))
if ND=""
SET ND="^53.4301A"
QUIT
+2 FOR RDA=$PIECE(ND,"^",3)+1:1
WRITE "."
IF '$DATA(^PS(53.43,1,1,RDA))
SET ^PS(53.43,1,1,RDA,0)=RDA
SET $PIECE(ND,"^",3)=RDA
SET $PIECE(ND,"^",4)=$PIECE(ND,"^",4)+1
SET ^PS(53.43,1,1,0)=ND
QUIT
+3 LOCK -^PS(53.43,1,1,0)
+4 FOR PSGPO=0:0
SET PSGPO=$ORDER(^PS(55,"AUDDD",PSGPO))
if 'PSGPO!(PSGPO'<PSGPOD)
QUIT
FOR DA(1)=0:0
SET DA(1)=$ORDER(^PS(55,"AUDDD",PSGPO,DA(1)))
if 'DA(1)
QUIT
FOR DA=0:0
SET DA=$ORDER(^PS(55,"AUDDD",PSGPO,DA(1),DA))
if 'DA
QUIT
if "DE"[$PIECE(^PS(55,DA(1),5,DA,0),"^",9)
DO DIK
+5 KILL %ZIS,ZTSAVE
SET H=ZTSK
SET IOP=PSGPOIO
SET %ZIS="NQ"
SET PSGJ=RDA
SET PSGTIR="^PSGPOR"
SET ZTDESC="PATIENT ORDER PURGE REPORT"
SET PSGTID=$HOROLOG
SET (ZTSAVE("PSGPOD"),ZTSAVE("PSGJ"))=""
DO ^%ZIS
DO ENTSK^PSGTI
SET ZTSK=H
+6 ;
DONE ;
+1 DO ENKV^PSGSETU
KILL AM,EDATE,H,POD,PSGJ,PSGPO,PSGPOD,PSGPOIO,ST,TRTN,ZTOUT
QUIT
+2 ;
DIK ;
+1 SET DIK="^PS(55,"_DA(1)_",5,"
DO ^DIK
KILL ^PS(55,DA(1),5,"B",DA,DA),^PS(55,"AUDDD",PSGPO,DA(1),DA),^PS(55,"AUE",DA(1),DA)
SET ^(0)=DA(1)_"^"_$SELECT($DATA(^PS(53.43,1,1,RDA,1,DA(1),0)):$PIECE(^(0),"^",2)+1,1:1)
QUIT
+2 ;
DTM ;
+1 WRITE !!," If a date is entered here, all orders for patients discharged before the date entered will be purged (deleted) from the computer. Please note that any orders for any patients admitted after the date entered will NOT be affected."
+2 WRITE !," The earliest discharge date found is ",PSGOD,!
QUIT
+3 ;
EDATE ;
+1 FOR X=0:0
SET X=$ORDER(^PS(53.5,"AB",X))
if 'X
QUIT
SET Y=$ORDER(^(X,0))
IF Y
IF Y<EDATE
SET EDATE=Y
+2 FOR X=0:0
SET X=$ORDER(^PS(53.5,"AF",X))
if 'X
QUIT
IF $DATA(^PS(53.5,X,0))
SET Y=$PIECE(^(0),"^",3)
IF Y
IF Y<EDATE
SET EDATE=Y
+3 QUIT
+4 ;
ENRX ; re-index 55 to be able to purge UD orders (AUDDD x-ref)
+1 KILL ^PS(55,"AUDDD")
DO NOW^%DTC
FOR P=0:0
SET P=$ORDER(^PS(55,P))
if 'P
QUIT
IF $DATA(^(P,5))
DO RX1
+2 KILL A
QUIT
+3 ;
RX1 ;
+1 FOR ON=0:0
SET ON=$ORDER(^PS(55,P,5,ON))
if 'ON
QUIT
if $PIECE($GET(^(+ON,0)),U,20)
SET ^PS(55,"AUDDD",$PIECE(^(0),U,20),P,+ON)=""
+2 QUIT
+3 ;S (D1,DL)=0,X=$O(^DGPM("ATID3",P,"")) I X S X=$O(^(+X,0)) I X S X=$G(^DGPM(X,0)),D2=+X,AD=+$G(^DGPM(+$P(X,U,14),0)) S:'D2 DL=AD I D2>+D1 S D1=D2
+4 ;S (D1,DL)=0 F Q=0:0 S Q=$O(^DPT(P,"DA",Q)) Q:'Q S AD=$S($D(^(Q,0)):+^(0),1:0),D2=$S($D(^(1)):+^(1),1:0) S:'D2 DL=AD I D2>+D1 S D1=D2_"^"_Q_"^"_AD
+5 if 'D1
QUIT
DO NOW^%DTC
if 'DL
SET DL=%
FOR Q=0:0
SET Q=$ORDER(^PS(55,P,5,"AUS",Q))
if 'Q
QUIT
if Q>DL
QUIT
FOR QQ=0:0
SET QQ=$ORDER(^PS(55,P,5,"AUS",Q,QQ))
if 'QQ
QUIT
SET $PIECE(^PS(55,P,5,QQ,0),"^",20)=+D1
SET ^PS(55,"AUDDD",+D1,P,QQ)=""
+6 if $DATA(^PS(55,"AUDDD",+D1,P))
SET ^(P)=$PIECE(D1,"^",2,3)
QUIT
+7 ;
ENDS ; delete single order
+1 FOR
READ !!,"DO YOU WANT TO DISCONTINUE THIS ORDER"
SET %=1
DO YN^DICN
if %
QUIT
WRITE !!?2,"Answer 'Y' to d/c this order now. (It will be deleted immediately.)",!,"Answer 'N' (or '^') to not d/c the order."
+2 IF %=1
Begin DoDot:1
+3 ;N DA,DIK,PSGPO I $P($G(^PS(55,PSGP,5,+PSGORD,0)),U,21) S X=$O(^ORD(101,"B","PS EVSEND OR",0))_";ORD(101,",PSJORDER=$$ORDER^PSJHLU(PSGORD),PSOC="OD",PSREASON="ORDER DISCONTINUED" D EN1^XQOR:X K X W !?3,"...one moment, please..."
+4 NEW DA,DIK,PSGPO
IF $PIECE($GET(^PS(55,PSGP,5,+PSGORD,0)),U,21)
DO EN1^PSJHL2(PSGP,"OD",PSGORD,"ORDER DISCONTINUED")
WRITE !?3,"...one moment, please..."
+5 SET PSGCANFL=1
SET DA(1)=PSGP
SET DA=+PSGORD
SET DIK="^PS(55,"_PSGP_",5,"
SET PSGPO=1
DO ^DIK
WRITE ".DONE!"
End DoDot:1
+6 KILL %,%Y
QUIT
