Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSGOE8

PSGOE8.m

Go to the documentation of this file.
  1. PSGOE8 ;BIR/CML3 - EDIT ORDERS IN 53.1 ;12 June 2019 09:31:53
  1. ;;5.0;INPATIENT MEDICATIONS ;**47,50,65,72,110,111,188,192,113,223,269,287,315,338,366,327,380**;16 DEC 97;Build 10
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. ; Reference to ^PS(50.7 is supported by DBIA# 2180
  1. ; Reference to ^PS(51.1 is supported by DBIA 2177
  1. ; Reference to ^PS(51.2 is supported by DBIA# 2178
  1. ; Reference to ^PSDRUG is supported by DBIA# 2192
  1. ;
  1. 101 ;Orderable Item
  1. S MSG=0,F2=101,PSGOOPD=PSGPD,PSGOOPDN=PSGPDN S:PSGOEEF(F2) BACK="101^PSGOE8"
  1. S %=1 I $P(PSJSYSU,";",3)>1 W !!,$C(7),"WARNING! If you change the drug of an order, the Dosage Ordered and Dispense",!,"Drug(s) are deleted." F W !,"Do you wish to continue" S %=2 D YN^DICN Q:%
  1. I %'=1 G DONE
  1. A101 ;
  1. I $$PNDREN($G(PSGORD)) D Q
  1. . W !!?5,"Orderable Item may not be edited at this point." D PAUSE^VALM1
  1. W !,"ORDERABLE ITEM: ",$S(PSGPD:PSGPDN_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOEE=0 G DONE
  1. ;; START NCC T4 MODS >> 327*RJS
  1. A201 I X="",PSGPD S X=PSGPDN I PSGPD'=PSGPDN,$L($$GET1^DIQ(50.7,PSGPD,.01)) G:'$G(ANQX) DONE
  1. S PSGPDOLD=PSGPD,PSGPDNOLD=PSGPDN,PSGPDRGOLD=PSGPDRG
  1. ;; END NCC T4 MODS >> 327*RJS
  1. I X="",PSGPD S X=PSGPDN I PSGPD'=PSGPDN,$D(^PS(50.7,PSGPD,0)) G DONE
  1. I $S(X="@":1,X]"":0,1:'PSGPD) W $C(7)," (Required)" S X="?" D ENHLP^PSGOEM(53.1,101) G A101
  1. I X?1."?" D ENHLP^PSGOEM(53.1,101)
  1. I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A101
  1. ;BHW;PSJ*5.0*192;Modify ^DIC call to use MIX^DIC and only B/C cross-references
  1. K DIC,D S DIC="^PS(50.7,",DIC(0)="EMQZ",DIC("S")="I $$ENOISC^PSJUTL(Y,""U"")",D="B^C" D MIX^DIC1 K DIC,D I Y'>0 G A101
  1. F S %=2 D DH,YN^DICN Q:%
  1. I %'=1 G A101
  1. S (PSGPDRG,PSGPD)=+Y,(PSGPDN,PSGPDRGN)=$$OINAME^PSJLMUTL(PSGPDRG)
  1. S PSGNEDFD=$$GTNEDFD^PSGOE7("U",PSGPDRG)
  1. S PSGPDNX=1,PSGDO="",(PSGPDRG,PSGPD)=+Y,(PSGPDN,PSGPDRGN)=$$OINAME^PSJLMUTL(PSGPDRG) K ^PS(53.45,PSJSYSP,2) S X=$O(^PSDRUG("ASP",PSGPD,0)) I X,'$O(^(X)) D
  1. .S ^PS(53.45,PSJSYSP,2,0)="^53.4502P^1^1",^(1,0)=X,^PS(53.45,PSJSYSP,2,"B",X,1)=""
  1. S PSGDRGTMP=X
  1. D ENDRG^PSGOEF1(PSGPD,0)
  1. ;; START NCC T4 MODS >> 327*RJS
  1. N CLOZFLG S CLOZFLG=$$ISCLOZ^PSJCLOZ(,PSGPD) I CLOZFLG D I $G(ANQX) K ANQX G A201
  1. .N PSGDRG S ANQX=0,PSGDRG=$P(CLOZFLG,U,2) D CLOZ^PSJCLOZ(DFN,PSGDRG)
  1. .I $G(ANQX) W ! S X=$E(PSGPDNOLD,0,4),PSGPDN=PSGPDNOLD,PSGPD=PSGPDOLD,PSGPDRG=PSGPDRGOLD K PSGDRGTMP,PSGPDOLD,PSGPDNOLD,PSGPDRGOLD
  1. ;; END NCC T4 MODS >> 327*RJS
  1. I $S($D(DTOUT):1,$D(DUOUT):1,$D(DIRUT):1,1:0) G DONE
  1. ;G DONE
  1. ;
  1. 109 ; dosage ordered
  1. S MSG=0,F2=109 S:$G(PSGOEEF(F2)) BACK="109^PSGOE8"
  1. A109 ;
  1. I $$PNDREN($G(PSGORD)) D Q
  1. . W !!?5,"Dosage may not be edited at this point." D PAUSE^VALM1
  1. S PSGOEEF(F2)=PSGOEE
  1. D EDITDOSE^PSJDOSE S X=PSGDO S:X="" PSGDREQ=1 G DONE
  1. W !,"DOSAGE ORDERED: ",$S(PSGDO]"":PSGDO_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOEE=0 G DONE
  1. I X=""&(PSGDO]"") S X=PSGDO
  1. I $$CHECK(PSJSYSP)&(X="")&(PSGDO']"") W $C(7)," (Required) " G A109
  1. I $$CHECK(PSJSYSP)&(X="@") W $C(7)," (Required) " G A109
  1. I '$$CHECK(PSJSYSP)&(X="@") S PSGDO="" G DONE
  1. I X?1."?" D ENHLP^PSGOEM(53.1,109) G A109
  1. I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A109
  1. I $E(X,$L(X))=" " F S X=$E(X,1,$L(X)-1) Q:$E(X,$L(X))'=" "
  1. I $S(X?.E1C.E:1,$L(X)>20:1,X="":0,X["^":1,X?1.P:1,1:X=+X) W $C(7)," ",$S(X?1.P!(X=""):"(Required)",1:"??") D ENHLP^PSGOEM(53.1,109) G A109
  1. S PSGDO=X G DONE
  1. ;
  1. 3 ; med route
  1. N PSGS0XT
  1. S MSG=0,F2=3 S:PSGOEEF(F2) BACK="3^PSGOE8"
  1. A3 I $$PNDREN($G(PSGORD)) D Q
  1. . W !!?5,"Med Route may not be edited at this point." D PAUSE^VALM1
  1. W !,"MED ROUTE: ",$S(PSGMR:PSGMRN_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOEE=0 G DONE
  1. I X="",PSGMR S X=PSGMRN I PSGMR'=PSGMRN,$D(^PS(51.2,PSGMR,0)) W " "_$P(^(0),"^",3) G DONE
  1. I $S(X="@":1,X]"":0,1:'PSGMR) W $C(7)," (Required)" S X="?" D ENHLP^PSGOEM(53.1,3) G A3
  1. I X="?" D MRSL^PSGOE4 ;*366
  1. I X?1."??" D ENHLP^PSGOEM(53.1,3)
  1. ;I X?1."?" D ENHLP^PSGOEM(53.1,3)
  1. I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A3
  1. D CKMRSL^PSGOE4 ;*366
  1. K DIC S DIC="^PS(51.2,",DIC(0)="EMQZX",DIC("S")="I $P(^(0),""^"",4)" D ^DIC K DIC I Y'>0 G A3 ;*366
  1. S PSGMR=+Y,PSGMRN=Y(0,0) G DONE
  1. ;
  1. 26 ; schedule
  1. S MSG=0,F2=26 S:PSGOEEF(F2) BACK="26^PSGOE8"
  1. A26 I $$PNDREN($G(PSGORD)) D Q
  1. . W !!?5,"Schedule may not be edited at this point." D PAUSE^VALM1
  1. W !,"SCHEDULE: ",$S(PSGSCH]"":PSGSCH_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOEE=0 G DONE
  1. S:X="" X=PSGSCH,PSGSCH="" I "@"[X W $C(7)," (Required)" S X="?" D ENHLP^PSGOEM(53.1,26) G A26
  1. S DOW=0 I $$DOW^PSIVUTL($$ENLU^PSGMI(X)) S DOW=1
  1. I X?1."?" D ENHLP^PSGOEM(53.1,26) G A26
  1. I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A26
  1. ;BHW;PSJ*5*188;Add flag and IEN return variable for PSGS0 (PSJ*5*134), Highlight Admin Times if they changed.
  1. N PSGOES,PSJSLUP,PSGSFLG S PSJSLUP=1,PSGSFLG=1 D EN^PSGS0 I '$D(X) W $C(7)," ??" S X="?" D ENHLP^PSGOEM(53.1,26) G A26
  1. I X'=PSGSCH D
  1. . K PSGDUR,PSGRMVT,PSGRMV,ND2P1 ;*315 Removal times are tied to ADMIN times.
  1. . N XX
  1. . S PSGSCH=X
  1. . I PSGS0Y'=PSGAT S PSGAT=PSGS0Y ;Change so that any schedule change will adjust the type and default the admin times - DRF
  1. . D ;Change schedule type to agree with schedule
  1. .. I $G(DOW) S PSGST="C",PSGSTN=$$ENSTN^PSGMI(PSGST) Q
  1. .. I (PSGSCH[" PRN")!(PSGSCH="PRN") I $$PRNOK^PSGS0(PSGSCH) S PSGOST=PSGST,PSGST="P",PSGSTN=$$ENSTN^PSGMI(PSGST) Q
  1. .. I '$G(PSGSCIEN),PSGSCH]"" S XX=+$O(^PS(51.1,"AC","PSJ",PSGSCH,0)),PSGSCIEN=XX
  1. .. S PSGOST=$G(PSGST),PSGST=$P($G(^PS(51.1,PSGSCIEN,0)),"^",5) I PSGST="D" S PSGST="C" ;DOW schedules are converted to Continuous
  1. .. S PSGSTN=$$ENSTN^PSGMI(PSGST)
  1. . I $G(PSJSYSW0),($P(PSJSYSW0,U,5)'=2),'$G(PSGEFN(8)) W !!,"NOTE: This may cause the Admin Times and the Start Time to be out of sync."
  1. . W !!,"NOTE: This change in schedule also changes the ADMIN TIMES and SCHEDULE TYPE.",!
  1. . S MSG=1 S:'$G(PSGOEEF(39)) PSGOEEF(39)=1 ;*287 - Prevent infinite loop editing admin times
  1. . I ($G(PSGRF)>1),PSGST="C" D
  1. ..S PSGF2=39,BACK="39^PSGOE81" D 39^PSGOE81 S BACK="26^PSGOE8",PSGF2=26,PSGOAT=PSGAT ;*315 Prompt for Admin to get DOA
  1. ..Q
  1. . I $G(PSJNEWOE) D PAUSE^VALM1
  1. I PSGST="O" S PSGOEEF(7)=1 I +$G(PSGRF) S PSGOEEF(25)=1 D 25^PSGOE81 S PSGF2=26
  1. G DONE
  1. ;
  1. 7 ; schedule type
  1. S MSG=0,F2=7 S:PSGOEEF(F2) BACK="7^PSGOE8"
  1. A7 W !,"SCHEDULE TYPE: "_$S(PSGSTN]"":PSGSTN_"// ",1:"") R X:DTIME S X=$TR(X,"coprocf","COPROCF") I X="^"!'$T S PSGOEE=0 W $C(7) G DONE
  1. I X="" S X=PSGST,PSGSTN=$$ENSTN^PSGMI(X) W:PSGSTN]"" " ",PSGSTN G DONE
  1. S:X="F" X="R"
  1. I ",?,??,C,O,OC,P,R,"'[(","_X_",") W " ??" G A7
  1. I $$PRNOK^PSGS0($G(PSGSCH)),X="C" W " ??" G A7
  1. I X="@"!(X?1."?") W:X="@" $C(7)," (Required)" S:X="@" X="?" D ENHLP^PSGOEM(53.1,7) G A7
  1. I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A7
  1. ;*223 Don't allow O sched type on C orders
  1. I X="O",$$SCHTP(PSGSCH)'="O" W !," SCHEDULE ("_PSGSCH_") is not a ONE TIME Schedule." G A7
  1. ;*269 Don't allow C sched type on O orders
  1. I X="C",$$SCHTP(PSGSCH)="O" W !," SCHEDULE ("_PSGSCH_") is not a CONTINUOUS Schedule." G A7
  1. S PSGOST=PSGST
  1. S PSGST=X,PSGSTN=$$ENSTN^PSGMI(X) W:PSGSTN]"" " ",PSGSTN
  1. I X="P",$G(PSGAT)]"" S PSGOAT=PSGAT S PSGAT="" D
  1. .W !!,"NOTE: This change in schedule type also changes the ADMIN TIMES.",!
  1. .S MSG=1,PSGOEEF(39)=1
  1. .I $G(PSJNEWOE) D PAUSE^VALM1
  1. ;
  1. DONE ;
  1. I PSGOEE G:'PSGOEEF(F2) @BACK S PSGOEE=PSGOEEF(F2)
  1. K F,F0,F2 Q
  1. ;
  1. DEL ; delete entry
  1. W !?3,"SURE YOU WANT TO DELETE" S %=0 D YN^DICN I %'=1 W $C(7)," <NOTHING DELETED>"
  1. Q
  1. ;
  1. DH ;
  1. W !!?2,"When the drug of an order is changed, the Dosage Ordered and Dispense Drug(s)",!,"for the order are no longer valid, and therefore deleted from the order.",!,"If possible, a new corresponding dispense drug will be added to the order."
  1. W !!?2,"Answer 'YES' to continue with this change. Answer 'NO' to select another",!,"drug or to accept the drug as it was. Enter an '^' to exit this edit." Q
  1. ;
  1. CHECK(PSJSYSP) ; Check to see if multiple dispense drugs
  1. ; Input - PSJSYSP
  1. ; Returns 0 = only one.
  1. ; 1 = more than one
  1. ; Checks Inactive Date and doesn't count if < or = today.
  1. N PSJRSB,PSJINACT,PSJRBCNT S PSJRBCNT=0
  1. F PSJRSB=0:0 S PSJRSB=$O(^PS(53.45,PSJSYSP,2,PSJRSB)) Q:'PSJRSB D
  1. .S PSJINACT=$P(^PS(53.45,PSJSYSP,2,PSJRSB,0),"^",3)
  1. .I (PSJINACT="")!((PSJINACT>0)&(PSJINACT>DT)) D
  1. ..S PSJRBCNT=$S('$D(PSJRBCNT):1,1:PSJRBCNT+1)
  1. Q $S(PSJRBCNT>1:1,1:0)
  1. ;
  1. PNDREN(PNDON) ;
  1. I PNDON'["P" Q 0
  1. S RNWL="^PS(53.1,"_+PNDON_",0)" S RNWL=$G(@(RNWL)) S RNWL=$S($P(RNWL,"^",24)="R":1,1:0)
  1. Q RNWL
  1. ;
  1. SCHTP(SCH) ; *223 Return SCHedule type
  1. N X I SCH="" Q ""
  1. S X=$O(^PS(51.1,"APPSJ",SCH,0))
  1. Q:'$G(X) ""
  1. Q $P(^PS(51.1,X,0),"^",5)
  1. ;