| 1 | PSGOD ;BIR/CML3-CREATES NEW ORDER FROM OLD ONE ;22 SEP 97 / 2:56 PM
|
|---|
| 2 | ;;5.0; INPATIENT MEDICATIONS ;**67,58,111,133**;16 DEC 97
|
|---|
| 3 | ;
|
|---|
| 4 | ; Reference to ^PS(55 is supported by DBIA 2191.
|
|---|
| 5 | ;
|
|---|
| 6 | I $P($G(^PS(55,PSGP,5,+PSJORD,0)),"^",22) D Q
|
|---|
| 7 | .W !,"This order is marked 'Not To Be Given' and can't be copied!" H 2
|
|---|
| 8 | F W !!,"Do you want to copy this order" S %=2 D YN^DICN Q:% D CH
|
|---|
| 9 | G:%'=1 DONE
|
|---|
| 10 | ;
|
|---|
| 11 | W !!,"...copying..." N OLDON
|
|---|
| 12 | N PSGPDRG
|
|---|
| 13 | S PSGOEPR=$P($G(^PS(55,PSGP,5.1)),"^",2),OLDON=PSGORD
|
|---|
| 14 | ;K PSGODN S F=$S((PSGORD["N")!(PSGORD["P"):"^PS(53.1,"_+PSGORD_",",1:"^PS(55,"_PSGP_",5,"_+PSGORD_",") F N=0,.2,2,6 S PSGODN(N)=$G(@(F_N_")"))
|
|---|
| 15 | K PSGODN S F=$S(PSGORD["P":"^PS(53.1,"_+PSGORD_",",1:"^PS(55,"_PSGP_",5,"_+PSGORD_",") F N=0,.2,2,6 S PSGODN(N)=$G(@(F_N_")"))
|
|---|
| 16 | S PSGPR=$P(PSGODN(0),"^",2),PSGMR=$P(PSGODN(0),"^",3),PSGSM=$P(PSGODN(0),"^",5),PSGHSM=$P(PSGODN(0),"^",6),PSGST=$P(PSGODN(0),"^",7)
|
|---|
| 17 | S PSGPDRG=+PSGODN(.2),PSGDO=$P(PSGODN(.2),"^",2)
|
|---|
| 18 | S PSGSI=PSGODN(6)
|
|---|
| 19 | ; The naked reference below refers to the full reference inside indirection to ^PS(55,PSGP,5,+PSGORD, or ^PS(55,PSGP,"IV",+PSGORD, or ^PS(53.1,+PSGORD
|
|---|
| 20 | S PSGODN(3)=0 F Q=0:0 S Q=$O(@(F_"3,"_Q_")")) Q:'Q I $D(^(Q,0)) S PSGODN(3,Q)=^(0),PSGODN(3)=PSGODN(3)+1 S ^PS(53.45,PSJSYSP,1,Q,0)=^(0)
|
|---|
| 21 | ;S:PSGODN(12)>0 ^PS(53.45,PSJSYSP,4,0)="^53.4504" S:PSGODN(3)>0 ^PS(53.45,PSJSYSP,1,0)="^53.4501"
|
|---|
| 22 | S:PSGODN(3)>0 ^PS(53.45,PSJSYSP,1,0)="^53.4501"
|
|---|
| 23 | ; The naked reference below refers to the full reference inside indirection to ^PS(55,PSGP,5,+PSGORD, or ^PS(55,PSGP,"IV",+PSGORD, or ^PS(53.1,+PSGORD
|
|---|
| 24 | S (PSGODN(1),Q)=0 F S Q=$O(@(F_"1,"_Q_")")) Q:'Q S ND=$G(^(Q,0)) I ND,'$P(ND,"^",3) S PSGODN(1)=PSGODN(1)+1,PSGODN(1,PSGODN(1))=$P(ND,"^",1,2) S ^PS(53.45,PSJSYSP,2,PSGODN(1),0)=^(0)
|
|---|
| 25 | S PSGS0Y=$P(PSGODN(2),"^",5),PSGS0XT=$P(PSGODN(2),"^",6),PSGNESD="",PSGSCH=$P(PSGODN(2),U)
|
|---|
| 26 | S PSGODF=1,PSGNEDFD=$P($$GTNEDFD^PSGOE7("U",+PSGPDRG),U)_"^^"_PSGST_"^"_PSGSCH
|
|---|
| 27 | W "." D ^PSGNE3
|
|---|
| 28 | K PSGEFN,PSGOEEF,PSGOEE,PSGOEOS S PSGEFN="1:13" F X=1:1:13 S PSGEFN(X)=""
|
|---|
| 29 | S PSGPDN=$$OINAME^PSJLMUTL(PSGPDRG),PSGOINST="",PSGSDN=$$ENDD^PSGMI(PSGNESD)_U_$$ENDTC^PSGMI(PSGNESD),PSGFDN=$$ENDD^PSGMI(PSGNEFD)_U_$$ENDTC^PSGMI(PSGNEFD)
|
|---|
| 30 | S PSGAT=PSGS0Y,PSGEBN=DUZ,PSGLIN=$$ENDD^PSGMI(PSGDT)_U_$$ENDTC^PSGMI(PSGDT),PSGEBN=$$ENNPN^PSGMI(DUZ),PSGSTAT=$S(PSGOEAV:"ACTIVE",1:"NON-VERIFIED")
|
|---|
| 31 | W "." D CHK^PSGOEV("^^"_PSGMR_"^^^^"_PSGST,PSGPDRG_U_PSGDO,PSGSCH_U_PSGNESD_"^^"_PSGNEFD)
|
|---|
| 32 | I $G(PSGSCH)]"" D
|
|---|
| 33 | .N X S X=PSGSCH N SWD,SDW,XABB,QX D ENOS^PSGS0 I $G(X)=""!$G(PSJNSS) S CHK=1 K PSJNSS Q
|
|---|
| 34 | .I $G(PSGAT)="",$G(PSGS0Y) S PSGAT=PSGS0Y
|
|---|
| 35 | .I $G(PSGAT),($G(PSGS0Y)="") S PSGS0Y=PSGAT
|
|---|
| 36 | .I $G(PSGS0XT)="D",$G(PSGS0Y)="" S CHK=1 D K PSJNSS
|
|---|
| 37 | ..W ! K DIR S DIR(0)="FOA",DIR("A")=" WARNING - Admin times are required for DAY OF WEEK schedules " D ^DIR K DIR
|
|---|
| 38 | S PSGSD=PSGNESD,PSGFD=PSGNEFD
|
|---|
| 39 | K PSJACEPT S VALMBCK="Q" D:$D(Y) EN^VALM("PSJU LM ACCEPT")
|
|---|
| 40 | I $G(PSJACEPT)=1 S VALMBCK="",PSJNOO=$$ENNOO^PSJUTL5("N")
|
|---|
| 41 | I '$G(PSJACEPT)!($G(PSJNOO)<0) W !!,"Order not copied." D PAUSE^VALM1 G ORIG
|
|---|
| 42 | S PSGNESD=PSGSD,PSGNEFD=PSGFD
|
|---|
| 43 | K PSGOEE D ^PSGOETO S PSJORD=PSGORD I PSGOEAV D
|
|---|
| 44 | .I '$D(PSGOEE),+PSJSYSU=3 D EN^PSGPEN(PSGORD)
|
|---|
| 45 | D GETUD^PSJLMGUD(PSGP,PSGORD),ENSFE^PSGOEE0(PSGP,PSGORD),^PSGOE1,EN^VALM("PSJ LM UD ACTION")
|
|---|
| 46 | ;
|
|---|
| 47 | S PSGCANFL=0,(PSGORD,PSJORD)=OLDON W !!,"You are finished with the new order.",!,"The following ACTION prompt is for the original order."
|
|---|
| 48 | K DIR S DIR(0)="E" D ^DIR K DIR
|
|---|
| 49 | ORIG ;Redisplay original order
|
|---|
| 50 | D GETUD^PSJLMGUD(PSGP,OLDON),INIT^PSJLMUDE(PSGP,OLDON)
|
|---|
| 51 | DONE ;
|
|---|
| 52 | K %,%H,%I,DA,F,N,PSGODN,PSGODF,PSGS0XT,PSGS0Y,PSGNESD,PSGTOL,PSGTOO,PSGUOW,X,Y,^PS(53.45,PSJSYSP,1),^PS(53.45,PSJSYSP,2)
|
|---|
| 53 | K PSGPR,PSGMR,PSGSM,PSGHSM,PSGST,PSGPDRG,PSGDO,PSGNEDFD,PSGSCH,PSGNEFD
|
|---|
| 54 | Q
|
|---|
| 55 | ;
|
|---|
| 56 | CH ;
|
|---|
| 57 | W !!?2,"Answer 'YES' to have a new, non-verified order created for this patient,",!,"using the information from this order. (The START and STOP dates will be",!,"recalculated.) Enter 'NO' (or '^') to stop now." Q
|
|---|
| 58 | ;
|
|---|
| 59 | WH ;
|
|---|
| 60 | W !!?2,"Answer 'YES' to take action on this new order. Enter 'NO' (or '^') to return",!,"to the original order now." Q
|
|---|
