source: FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGPEN.m@ 1535

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

initial load of FOIAVistA 6/30/08 version

File size: 5.5 KB
Line 
1PSGPEN ;BIR/CML3-FIND DEFAULT FOR PRE-EXCHANGE NEEDS ;03 Feb 99 / 9:13 AM
2 ;;5.0; INPATIENT MEDICATIONS ;**30,37,50,58,115,110,127,129**;16 DEC 97
3 ;
4 ; References to ^PSD(58.8 supported by DBIA #2283.
5 ; References to ^PSI(58.1 supported by DBIA #2284.
6 ; Reference to ^PS(55 is supported by DBIA #2191.
7 ; Reference to ^PSDRUG is supported by DBIA #2192.
8 ; Reference to ^PS(59.7 is supported by DBIA #2181.
9 ;
10EN(PSGPENO) ;
11 S PSGPENO=+PSGPENO
12 N PSJSITE,PSJPRN S PSJSITE=0,PSJSITE=$O(^PS(59.7,PSJSITE)) I $P($G(^(PSJSITE,26)),U,5)=1 S PSJPRN=1
13 D NOW^%DTC S PSGDT=%,DT=$$DT^XLFDT,PSGPEN="" S ND=$G(^PS(55,PSGP,5,PSGPENO,0))
14 S PSGPENWS=0 I PSJPWD F Q=0:0 S Q=$O(^PS(55,PSGP,5,PSGPENO,1,Q)) Q:'Q S ND=$G(^(Q,0)) I ND,'$P(ND,"^",3),($D(^PSI(58.1,"D",+ND,PSJPWD))!$D(^PSD(58.8,"D",+ND,PSJPWD))) S PSGPENWS=1 Q
15 I PSGPENWS F S Q=$O(^PS(55,PSGP,5,PSGPENO,1,Q)) Q:'Q S ND=$G(^(Q,0)) I ND,'$P(ND,"^",3) S:'$D(^PSI(58.1,"D",+ND,PSJPWD))&'$D(^PSD(58.8,"D",+ND,PSJPWD)) PSGPENWS=0 Q:'PSGPENWS S $P(PSGPENWS,"^",2)=1
16 I PSGPENWS W !!,"The dispense drug",$E("s",$P(PSGPENWS,"^",2))," for this order ",$S($P(PSGPENWS,"^",2):"are",1:"is a")," WARD STOCK item",$E("s",$P(PSGPENWS,"^",2)),"." S PSGPEN=0
17 I 'PSGPENWS,PSJPWD S WG=+$O(^PS(57.5,"AB",PSJPWD,0)),PSGPLS=$P($G(^PS(55,PSGP,5,PSGPENO,2)),"^",2) I PSGPLS D
18 .S PSGPLF=$O(^PS(53.5,"AB",WG,PSGDT))
19 .N RNDT,PSJRNOS S RNDT=$$LASTREN^PSJLMPRI(PSGP,$S($G(PSJORD)["P":PSJORD,1:"")),PSJRNOS=$P(RNDT,"^",4) I PSJRNOS,'$G(PSJREN) S PSGPLS=PSJRNOS
20 .I $G(PSJREN),$G(PSJORD)["U" S PSJRNOS=$P(^PS(55,PSGP,5,+PSJORD,2),"^",4) S PSGPLS=$S(PSJRNOS>PSGDT:PSJRNOS,1:$$DATE2^PSJUTL2(PSGDT))
21 .D:'PSGPLF GF I PSGPLF S PSGPLO=PSGPENO D NCE,^PSGPL0 S:PSGPLC'<0 PSGPEN=PSGPLC
22 I $G(PSGPRIO)="DONE" S PSGPEN=0
23 ;
24UPDD ;
25 N DIR S DIR(0)="NOA^0:9999:0",DIR("A")="Pre-Exchange DOSES: ",DIR("?")="^D DH^PSGPEN" S:PSGPEN]"" DIR("B")=PSGPEN W ! D ^DIR G:'Y DONE S PSGY=+Y W !!,"...updating dispense drug(s)..."
26 F FQ=0:0 S FQ=$O(^PS(55,PSGP,5,PSGPENO,1,FQ)) Q:'FQ S ND=$G(^(FQ,0)),$P(^(0),"^",9)="" I ND,'$P(ND,"^",3) D DD
27 ;
28DONE ;
29 I $P(PSJSYSW0,"^",29)="",$$DEFON^PSGPER1 S $P(PSJSYSW0,"^",29)=0
30 K PSGID,PSGMAR,PSGOD,PSGPLC,PSGPLF,PSGPLO,PSGPLS,PSGPLUD,WG S:$G(PSJREN) DUOUT=0 Q
31 ;
32NCE ;
33 W !!,"The next cart exchange is ",$$ENDTC^PSGMI(PSGPLF),! Q
34 ;
35GF ;
36 S QQ=0 F Q=0:0 S Q=$O(^PS(53.5,"AB",WG,Q)) Q:'Q S QQ=Q
37 I QQ S QQ=$O(^PS(53.5,"AB",WG,QQ,0)) I QQ,$D(^PS(53.5,QQ,0)) S QQ=$P(^(0),"^",4) I QQ>PSGDT S PSGPLF=QQ
38 Q
39 ;
40DD ;
41 N DA S DRG=$S($P(ND,"^")="":"NOT FOUND",'$D(^PSDRUG(+ND,0)):"NOT FOUND ("_$P(ND,"^")_")",$P(^(0),"^")]"":$P(^(0),"^"),1:$P(ND,"^")_";PSDRUG("),UD=$S('$P(ND,"^",2):1,1:$P(ND,"^",2))
42 W !,"...",DRG,?45,"U/D: ",UD,"..."
43 S PSGDA=PSGY I 'PSGPENWS,ND,PSJPWD,($D(^PSI(58.1,"D",+ND,PSJPWD))!$D(^PSD(58.8,"D",+ND,PSJPWD))) D PSGPENWS Q:'PSGDA
44 K DA,DR S PSGDA=$S(UD#1:(PSGDA*((UD\1)+1)),1:PSGDA*UD)
45 S DIE="^PS(55,"_PSGP_",5,"_PSGPENO_",1,",DA(2)=PSGP,DA(1)=PSGPENO,DA=FQ,DR=".09////"_PSGDA D ^DIE
46 S PSGPXN=$G(PSGPXN)
47 D:'PSGPXN
48 .D NOW^%DTC L +^PS(53.4,0):0 S ND=$G(^PS(53.4,0)) S:ND="" ND="PRE-EXCHANGE NEEDS^53.4P" F PSGPXN=$P(ND,"^",3)+1:1 I '$D(^PS(53.4,PSGPXN)) L +^PS(53.4,PSGPXN):0 I S ^PS(53.4,0)=$P(ND,"^",1,2)_"^"_PSGPXN_"^"_($P(ND,"^",4)+1) L -^PS(53.4,0) Q
49 .S ^PS(53.4,PSGPXN,0)=DUZ_"^"_%,^PS(53.4,"B",DUZ,PSGPXN)="",^PS(53.4,"AUD",DUZ,%,PSGPXN)="" L -^PS(53.4,PSGPXN) Q
50 I $D(^PS(53.4,PSGPXN,1,PSGP,1,PSGPENO,1,FQ,0)) S $P(^(0),"^",2)=$P(^(0),"^",2)+PSGDA Q
51 ; naked reference below refers to line above
52 S ^(0)=FQ_"^"_PSGDA I $D(^PS(53.4,PSGPXN,1,PSGP,1,PSGPENO,1,0)) S $P(^(0),"^",3,4)=FQ_"^"_($P(^(0),"^",4)+1) Q
53 ; naked reference below refers to line above
54 S ^(0)="^53.401101A^"_FQ_"^1" Q:$D(^PS(53.4,PSGPXN,1,PSGP,1,PSGPENO,0)) S ^(0)=PSGPENO
55 I $D(^PS(53.4,PSGPXN,1,PSGP,1,0)) S $P(^(0),"^",3,4)=PSGPENO_"^"_($P(^(0),"^",4)+1) Q
56 ; naked reference below is from line above
57 S ^(0)="^53.4011A^"_PSGPENO_"^1" Q:$D(^PS(53.4,PSGPXN,1,PSGP,0)) S ^(0)=PSGP
58 I $D(^PS(53.4,PSGPXN,1,0)) S $P(^(0),"^",3,4)=PSGP_"^"_($P(^(0),"^",4)+1) Q
59 ; naked reference below is from line above
60 S ^(0)="^53.401PA^"_PSGP_"^1" Q
61 ;
62DH ;
63 W !!?2,"Enter a number from 0 to 9999, 0 decimal digits."
64 W !!?2,"Enter the number DOSES needed for this order until the next cart exchange.",!,"This will be the number of times the order will be administered to the patient",!,"from the start of the order until the next cart exchange."
65 W !!?2,"PLEASE NOTE that this is DOSES, and NOT UNITS. The doses entered will be",!,"converted to units for each dispense drug of this order, as each dispense drug",!,"may have a different units per dose." Q
66 ;
67PSGPENWS ;
68 W !,"This dispense drug is a WARD STOCK item."
69 W !,"Would you like to:",!?3,"1 - Enter 0 (no) doses needed for this dispense drug.",!?3,"2 - Enter ",PSGDA," doses needed for this dispense drug.",!?3,"3 - Enter another amount as the doses needed for this dispense drug."
70 K DIR S DIR(0)="SA^1:0 (no) doses;2:"_PSGDA_" doses;3:another amount",DIR("A")="Select ACTION: ",DIR("?")="^D WH^PSGPEN" W ! D ^DIR I Y=1!'Y S PSGDA=0 Q
71 Q:Y=2 K DIR S DIR(0)="NA^0:9999:0",DIR("A")="Pre-Exchange DOSES for this dispense drug: ",DIR("?")="^D WDH^PSGPEN" W ! D ^DIR S PSGDA=+Y Q
72 ;
73WH ;
74 S Q="This dispense drug ("_DRG_") is a ward stock item. Select:"
75 W !! F Q1=1:1:$L(Q," ") S Q2=$P(Q," ",Q1) W:$X+$L(Q2)>78 ! W Q2," "
76 W !?3,"1 to enter 0 (no) pre-exchange doses for this dispense drug.",!?3,"2 to enter ",PSGDA," doses for this dispense drug.",!?3,"3 to enter another amount for this dispense drug." Q
77 ;
78WDH ;
79 W !!?2,"Enter a number from 0 to 9999, 0 decimal digits. If you enter an '^' to exit",!,"NO pre-exchange doses will be entered for this dispense drug." Q
Note: See TracBrowser for help on using the repository browser.