10:21 AM  27-APR-99
Inpatient Medications patch 2
PSGPO
PSGPO ;IHS/DSD/ENM/B'ham ISC/CML3 - PURGE PATIENT'S ORDERS ;4/15/91  22:36 [ 04/27/1999  9:50 AM ]
 ;;3.2;INPATIENT MEDICATIONS;**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

PSIVCHK
PSIVCHK ; B'ham ISC/PR - CHECK ORDER FOR INTEGRITY ;6/4/90  16:23 [ 04/27/1999  9:49 AM ]
 ;;3.2;INPATIENT MEDICATIONS;**2**;04/27/99
 ;Need DFN and ON
SETP S Y=^PS(55,DFN,"IV",ON,0) F X=1:1:23 S P(X)=$P(Y,"^",X)
 W ! S ERR=0 S:P(4)="C" P(4)=P(23) I P(4)="S" S P(4)=$S(P(5):"P",1:"A")
 I P(1)<1!(P(1)'=ON) S ERR=1 W !,"*** Order Number is invalid !!"
 I P(11)]"" S X=P(11) X $P(^DD(51.1,1,0),"^",5,999) I '$D(X) W !,"*** Your administration time(s) are in an invalid format !" S ERR=1
 I '$D(^PS(55,"AIV",+P(3),DFN,ON)) S ERR=1 W !,"*** Stop date/time x-ref is non-existent !"
 I P(15)<0 S ERR=1 W !,"*** Time interval between doses is less than zero !"
 I P(4)="P",(P(15)!("^NOW^STAT^ONCE^"[("^"_$P(P(9)," ")_"^"))),P(11)["-" S:'ERR ERR=2 W !,"*** WARNING -- You have a non-standard schedule ...",!?15,"with an administration time."
 N XX F XX=2,3 S X=$$FMTH^XLFDT(P(XX)) I '$P(X,",",2)!($L(P(XX))>12) S ERR=1 W !,"*** ",$S(XX=2:"Start",1:"Stop")," date is in an invalid format or must contain time !" ;IHS/DSD/ENM 04/01/99 Y2K FIX
 ;F X=2,3 I P(X)'?1"2"6N1"."1N.N!($L(P(X))>12) S ERR=1 W !,"*** ",$S(X=2:"Start",1:"Stop")," date is in an invalid format or must contain time !"
 I P(2)>P(3) S ERR=1 W !,"*** Start date/time CANNOT be greater than the stop date/time"
INF I P(8)="","AH"[P(4) S ERR=1 W !,"*** You have no infusion rate defined !"
 I "AH"[P(4),P(8)'?1N.N1" ml/hr",P(8)'?.E1"@"1N.N S ERR=1 W !,"*** Your infusion rate is in an invalid format !"
 I P(8)="",P(4)="P" S:'ERR ERR=2 W !,"*** WARNING -- You have not specified an infusion rate. "
 I ^DD(55.01,.04,0)'[(P(4)_":")!(P(4)="") S ERR=1 W !,"*** Type of order is invalid !"
 I ^DD(55.01,100,0)'[(P(17)_":")!(P(17)="") S ERR=1 W !,"*** Status of order is invalid !"
AH ;
 I "HA"[P(4),(P(11)]""!(P(9)]"")) W !,*7,"Order type is an admixture, hyperal, or continuous syringe, and you have",!,"a schedule and/or administration times defined!"
 I  F Q=0:0 W !,"Ok to delete these fields" S %=1 D YN^DICN D NULSET Q:%
 K % I P(6)="" S ERR=1 W !,"*** You have not entered a physician!"
 I P(6)]"",'$D(^DIC(16,P(6),0)) S ERR=1 W !,"*** Physician entered does not exist!"
 I P(6)]"",'$S($D(^DIC(6,P(6),"I")):DT<^("I")!'^("I"),1:1) S ERR=1 W !,"*** Physician entered is no longer active."
 I P(9)="",P(4)="P" S ERR=1 W !,"*** No schedule exists for this order!"
 I P(10)<0 S ERR=1 W !,"*** No. of labels last printed is less than zero!"
 I P(11)="",P(4)="P",'P(15),"^NOW^STAT^ONCE^"'[("^"_$P(P(9)," ")_"^") S ERR=1 W !,"*** There are no administration times defined for this order!"
 G ^PSIVCHK1
NULSET ;Delete admin/schedule fields for hyperals and/or admixtures
 I '% W !!?2,"Enter 'YES' to delete the schedule and/or administration times fields from",!,"this order.  Enter 'NO' (or '^') to leave the fields intact.",! Q
 S:%=1 $P(^PS(55,DFN,"IV",ON,0),U,9)="",$P(^(0),U,11)=""
 Q
CKO S P16=0,PSIVEXAM=1,PSIVCT=1 D PSIVCHK S PSIVNOL=1 W ! D ^PSIVLABL K PSIVEXAM Q:'ERR
 I PSIVREA="V",(ERR=1) W !,"This is an incomplete order!",!,"Please complete and then verify the order",! S XED=1 Q
 I ERR=2 F J=0:0 W !!,"Since there is a warning with this order.",!,"do you wish to re-edit this order" S %=1 D YN^DICN Q:%  W !!,"Answer 'YES' to re-edit this order."
 I ERR=2,%=1 K DA,DIE,DR S DR="[PSJIEDT]",DA=DFN,DIE="^PS(55," D ^DIE K DA,DIE,DR G CKO
 I ERR=1,P17'="N" W !,"Please re-edit this order.",! K DA,DIE,DR S DR="[PSJIEDT]",DA=DFN,DIE="^PS(55," D ^DIE K DA,DIE,DR G CKO
 Q