5:19 PM  8-DEC-98
Inpatient Pharmacy Y2K Fix
PSGPO
PSGPO ;IHS/DSD/ENM/B'ham ISC/CML3 - PURGE PATIENT'S ORDERS ;4/15/91  22:36 [ 12/04/1998  8:23 AM ]
 ;;3.2;INPATIENT PHARMACY;**1**;12/04/98
 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
 ;Y2000 beginning Y2K fix...IHS/DSD/ENM 08/21/98
 S EDATE=4000000 D:$S($D(^PS(53.5,"B")):1,1:$D(^("F"))) 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 EDATE=3000000 D:$S($D(^PS(53.5,"B")):1,1:$D(^("F"))) EDATE I EDATE<3000000 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
 ;Y2000 ending Y2K fix IHS/DSD/ENM 08/21/98
 S PSGID=POD X psgdtc S Y=-1
 ;Y2000 beginning Y2K fix...IHS/DSD/ENM 08/21/98
 F Q=0:0 K %DT S %DT="EPTX" S:EDATE<4000000 %DT(0)=-EDATE R !!,"PURGE ORDERS FOR PATIENTS DISCHARGED BEFORE WHAT DATE: ",X:DTIME W:'$T *7 S:'$T X="^" D DTM:X?1."?",^%DT:"^"'[X I Y>0!("^"[X) W:Y'>0 !,"No date chosen, or orders purged.",! Q
 ;F Q=0:0 K %DT S %DT="EPTX" S:EDATE<3000000 %DT(0)=-EDATE R !!,"PURGE ORDERS FOR PATIENTS DISCHARGED BEFORE WHAT DATE: ",X:DTIME W:'$T *7 S:'$T X="^" D DTM:X?1."?",^%DT:"^"'[X I Y>0!("^"[X) W:Y'>0 !,"No date chosen, or orders purged.",! Q
 ;Y2000 ending Y2K fix IHS/DSD/ENM 08/21/98
 G:Y'>0 DONE W !!,"This purge will automatically be queued." K %ZIS,IO("C"),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, or 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 ;
 L ^PS(53.43,1,1,0) S ND=$S($D(^PS(53.43,1,1,0)):^(0),1:"^53.4301A")
 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
 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 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 ordersfor 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,"B",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,"F",X)) Q:'X  I $D(^PS(53.5,X,0)) S Y=$P(^(0),"^",2) 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 ;
 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  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 Q=0:0 R !!,"DO YOU WANT TO CANCEL (DELETE) THIS ORDER" S %=1 D YN^DICN Q:%  W !!?2,"Answer 'Y' to cancel this order now.  (It will be deleted immediately.)",!,"Answer 'N' (or '^') to not cancel the order."
 I %=1 S DA(1)=PSGP,DA=+PSGORD,DIK="^PS(55,"_PSGP_",5,",PSGPO=1 W !?3,"...one moment, please..." D ^DIK K DIK,DA,PSGPO W ".DONE!" S PSGCANFL=1
 K %,%Y Q