source: FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGPO.m@ 1757

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 4.1 KB
Line 
1PSGPO ;BIR/CML3-PURGE PATIENT'S ORDERS ; 15 May 98 / 10:42 AM
2 ;;5.0; INPATIENT MEDICATIONS ;**3**;16 DEC 97
3 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
4 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
5 S PSGOD=$$ENDTC^PSGMI(POD),Y=-1
6 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
7 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
8 I POP S IOP=PSGION D ^%ZIS W !?3,"No device selected for purge run." G DONE
9 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
10 ;
11ENQ ;
12 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
13 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
14 L -^PS(53.43,1,1,0)
15 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
16 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
17 ;
18DONE ;
19 D ENKV^PSGSETU K AM,EDATE,H,POD,PSGJ,PSGPO,PSGPOD,PSGPOIO,ST,TRTN,ZTOUT Q
20 ;
21DIK ;
22 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
23 ;
24DTM ;
25 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."
26 W !," The earliest discharge date found is ",PSGOD,! Q
27 ;
28EDATE ;
29 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
30 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
31 Q
32 ;
33ENRX ; re-index 55 to be able to purge UD orders (AUDDD x-ref)
34 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
35 K A Q
36 ;
37RX1 ;
38 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)=""
39 Q
40 ;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
41 ;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
42 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)=""
43 S:$D(^PS(55,"AUDDD",+D1,P)) ^(P)=$P(D1,"^",2,3) Q
44 ;
45ENDS ; delete single order
46 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."
47 I %=1 D
48 .;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..."
49 .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..."
50 .S PSGCANFL=1,DA(1)=PSGP,DA=+PSGORD,DIK="^PS(55,"_PSGP_",5,",PSGPO=1 D ^DIK W ".DONE!"
51 K %,%Y Q
Note: See TracBrowser for help on using the repository browser.