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

PSGOE42.m

Go to the documentation of this file. 
  1. PSGOE42 ;BIR/CML - REGULAR ORDER ENTRY (CONT.) ;Feb 02, 2022
  1.  ;;5.0;INPATIENT MEDICATIONS ;**366,327,399,372**;16 DEC 97;Build 153
  1.  ;
  1.  ; Reference to $$SDEA^XUSER supported by DBIA #2343
  1.  ;
  1. 1 I $G(PSGCLOZ) K PSGCLOZ Q  ;NCC remediation *327/RJS QUIT IF STOP DATE HAS BEEN MODIFIED AND PROCESS
  1.  S:'$G(PSGPR) PSGPR=0 S:'$D(PSGPRN) PSGPRN=""  ; must have provider info
  1.  ; provider
  1.  ;*372-cs schedule check
  1.  N PSJDEA,PSDEA,PDEA,PSPPKG S (PSDEA,PDEA)=""
  1.  I $G(PSGPDRG)]"" D  G:PDEA A1
  1.  .S PSPPKG=$S(PSJPROT=1:"U",PSJPROT=3:"UI",1:"") Q:PSPPKG=""
  1.  .S PSJDEA=$$OIDEA^PSSOPKI(PSGPDRG,PSPPKG),PSDEA=$P(PSJDEA,";",2)
  1.  .I PSDEA>1,PSDEA<6 S PDEA=1
  1.  I '$G(PSJSYSU) S PSTMPI=PSGPR,PSTMPN=PSGPRN G A1
  1.  I $S(+PSJSYSU=3:0,1:$P(PSJSYSU,";",2)) G:$P(PSJSYSW0,"^",24) 5 G DONE
  1.  S PSTMPI=PSGPR,PSTMPN=PSGPRN
  1. A1 ;
  1.  ;*366 - check provider credentials
  1.  I PSGPR N PSJACT S PSJACT=$$ACTPRO^PSGOE1(PSGPR) S:'PSJACT PSGPR=0,PSGPRN=""
  1.  W !,"PROVIDER: ",$S(PSGPR:PSGPRN_"// ",1:"") R X:DTIME I X="^" W $C(7) S PSGOROE1=1 G DONE
  1.  I $S(X="":'PSGPR,1:X="@") W $C(7),"  (Required)" S X="?",PSGF2=1 D ENHLP^PSGOEM(53.1,1) G 1
  1.  I X="",PSGPR S X=PSGPRN I PSGPR'=PSGPRN,$$GET1^DIQ(200,PSGPR,53.1,"I") W "    "_$$GET1^DIQ(200,PSGPR,53.2)_"    "_$$GET1^DIQ(200,PSGPR,53.3) S PSGFOK(1)="" G A2
  1.  S PSGF2=1 I X?1."?" D ENHLP^PSGOEM(53.1,1)
  1.  I $E(X)="^" D FF G:Y>0 @Y G 1
  1.  K DIC S DIC="^VA(200,",DIC(0)="EMQZ",DIC("S")="I $$ACTPRO^PSGOE1(+Y)" D ^DIC K DIC I Y'>0 G 1
  1.  S PSGPR=+Y,PSGPRN=$P(Y(0,0),"^"),PSGFOK(1)=""
  1. A2 ;; START NCC T4 MODS >> 327*RJS
  1.  I $$ISCLOZ^PSJCLOZ(,,,,PSGDRG) D
  1.  .S ANQX=0 D PROVCHK^PSJCLOZ(PSGPR) ;(PSGP,PSGDRG)
  1.  .I ANQX=0 K PSTMPN,PSTMPI
  1.  I $G(ANQX) S PSGPR=PSTMPI,PSGPRN=PSTMPN W ! K ANQX G A1
  1.  ;; END NCC T4 MODS << 327*RJS
  1.  ;*372-cs schedule check
  1.  I PDEA S PDEA=$$SDEA^XUSER(,+PSGPR,PSDEA,,"I") I (PDEA=1)!(PDEA=2)!(+PDEA=4) D  G A1
  1.  .W !,"Provider not authorized to prescribe medications in Federal Schedule "_PSDEA_".",!,"Please contact the provider.",!
  1. 5 ; self med
  1.  I '$P(PSJSYSW0,"^",24) G DONE
  1. A5 W !,"SELF MED: " W:PSGSM]"" $P("NO^YES","^",PSGSM+1),"// " R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOROE1=1 G DONE
  1.  I "01"[X,$L(X)<2 S:PSGSM=""&(X]"") PSGSM=X W:PSGSM]"" "  (",$P("NO^YES","^",PSGSM+1),")" G DONE
  1.  I X="@" W:PSGSM="" $C(7),"  ??" G:PSGSM="" A5 D DEL G:%'=1 A5 S (PSGSM,PSGHSM)="" G DONE
  1.  S PSGF2=5 I X?1"^".E D FF G:Y>0 @Y G A5
  1.  I X?1."?" S PSGF2=5 D ENHLP^PSGOEM(53.1,5) G A5
  1.  D YN I  S PSGSM=$E(X)="Y",PSGFOK(5)="" G 6:PSGSM,DONE
  1.  W $C(7) D ENHLP^PSGOEM(53.1,5) G A5
  1.  ;
  1. 6 ; hospital supplied self med
  1.  W !,"HOSPITAL SUPPLIED SELF MED: " W:PSGHSM]"" $P("NO^YES","^",PSGHSM+1),"// " R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOROE1=1 G DONE
  1.  I "01"[X,$L(X)<2 S:PSGHSM=""&(X]"") PSGHSM=X W:PSGHSM]"" "  (",$P("NO^YES","^",PSGHSM+1),")" G DONE
  1.  I X="@" W:PSGHSM="" $C(7),"  ??" G:PSGHSM="" 6 D DEL G:%'=1 6 S PSGHSM="" G DONE
  1.  S PSGF2=6 I X?1"^".E D FF G:Y>0 @Y G 6
  1.  I X?1."?" D ENHLP^PSGOEM(53.1,6) G 6
  1.  D YN I  S PSGHSM=$E(X)="Y" G DONE
  1.  W $C(7) S PSGF2=6 D ENHLP^PSGOEM(53.1,6) G 6
  1.  Q
  1.  ;
  1. DONE ;
  1.  K F,F0,F1,PSGF2,F3,PSG,SDT Q
  1.  ;
  1. FF ; up-arrow to another field
  1.  D ENFF^PSGOEM I Y>0,Y'=1,Y'=5 S Y=Y_"^PSGOE4"_$S("^109^13^3^7^26^"[("^"_Y_"^"):"",1:1)
  1.  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. YN ; yes/no as a set of codes
  1.  I X'?.U F Y=1:1:$L(X) I $E(X,Y)?1L S X=$E(X,1,Y-1)_$C($A(X,Y)-32)_$E(X,Y+1,$L(X))
  1.  F Y="NO","YES" I $P(Y,X)="" W $P(Y,X,2) Q
  1.  Q
  1.  ;
  1. 2 ; dispense drug multiple
  1.  I PSGDRG,'$D(^PS(53.45,PSJSYSP,2)) S ^(2,0)="^53.4502P^1^1",^(1,0)=PSGDRG_"^"_PSGUD
  1.  K DA,DR S DIE="^PS(53.45,",DA=PSJSYSP,DR=2,DR(2,53.4502)=$S($G(PSGFOK(13)):.02,1:".01;.02") D ^DIE
  1.  I '$O(^PS(53.45,PSJSYSP,2,0)) W $C(7),!!,"WARNING: This order must have at least one dispense drug before pharmacy can",!?9,"verify it!"
  1.  I $G(PSGFOK(13)) Q
  1.  G @FB
  1.  ;
  1. IND(OI) ;*399-IND
  1. INDA ;
  1.  N INDLST,DIR,SEL,I,INDCAT,CHK,CNT K DUOUT,DTOUT,DIROUT,DIRUT
  1.  S (CHK,CNT)=0,PSGF2=132
  1.  I '$G(OI) S Y=99,PSGIND="" G CIND
  1.  D INDCATN^PSS50P7(OI,"PSJDIND")
  1.  I '$O(^TMP($J,"PSJDIND",0)) S Y=99 G CIND
  1.  S (SEL,I)="" F  S I=$O(^TMP($J,"PSJDIND",I)) Q:'I  D
  1.  . S INDCAT=$P($G(^TMP($J,"PSJDIND",I)),"^")
  1.  . I $G(PSGIND)]"",INDCAT=PSGIND S CHK=1
  1.  . S CNT=CNT+1,INDLST(CNT)=INDCAT,DIR("L",CNT)="  "_CNT_"   "_INDCAT S:CNT=1 SEL=CNT_":"_INDCAT S:CNT>1 SEL=SEL_";"_CNT_":"_INDCAT
  1.  W !,"INDICATION:"
  1.  S DIR(0)="SO^"_SEL_";99:Free Text entry",DIR("A")="Select INDICATION from the list"
  1.  S DIR("L")="  99  Free Text entry"
  1.  S:CHK DIR("B")=PSGIND S:'CHK&(PSGIND]"") DIR("B")=99
  1.  S DIR("?")="This field contains the Indication For Use and must be 3-40 characters in length"
  1.  D ^DIR
  1.  I X="^"!($G(DTOUT))!($G(DIROUT)) S:'$G(PSGOEE) PSGOROE1=1 Q
  1.  I Y=99 S:CHK PSGIND="" G CIND
  1.  I X="@",$G(PSGIND)]"" D DEL G:%'=1 INDA S PSGIND="" Q
  1.  I X="@" S PSGIND="" G INDA
  1.  S PSGFOK(132)=""
  1.  S:Y>0 PSGIND=Y(0)
  1.  Q
  1. CIND ;
  1.  I Y=99 N I,J,IND,DA D  G:$G(Y)=99 CIND
  1.  . K X,Y,DIRUT,DTOUT,DUOUT,DIROUT,DIR
  1.  . S:$G(PSGIND)]"" DIR("B")=PSGIND
  1.  . S DIR(0)="53.1,132",DIR("A")="INDICATION" D ^DIR
  1.  . I X="^"!($G(DTOUT))!($G(DIROUT)) S:'$G(PSGOEE) PSGOROE1=1 Q
  1.  . I X="@",$G(PSGIND)]"" D DEL G:%'=1 INDA S PSGIND="" Q
  1.  . I X="@" S PSGIND="" G INDA
  1.  . I $L(X," ")=1,$L(X)>32 W $C(7),!?5,"MAX OF 32 CHARACTERS ALLOWED WITHOUT SPACES.",! S Y=99 Q
  1.  . S IND="" F I=1:1:$L(X," ") Q:I=""  S J=$P(X," ",I) D  I '$D(X) S Y=99 Q
  1.  . .I $L(J)>32 W $C(7),!?5,"MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES.",! K X Q
  1.  . .S:J]"" IND=$S($G(IND)]"":IND_" ",1:"")_J
  1.  . Q:$G(Y)=99
  1.  . S PSGIND=$$ENLU^PSGMI(IND)
  1.  . S PSGFOK(132)=""
  1.  Q
  1.  ;
  1.  ;do we have any changes for indication?
  1.  ;compare indication passed in PSJNEWVL parameter with value stored in the field (#132) of the file (#53.1) with the IEN=+PSJORD
  1. DIFFIND(PSJDFN,PSJORD,PSJNEWVL) ;
  1.  ; PSJDFN = IEN of #2 (not required for non-verified orders)
  1.  ; PSJORD = IEN of #53.1/55 + indication like "P","U","V", example = "4033P"
  1.  ; PSJNEWVL the new value after editing
  1.  ; returns:
  1.  ; piece #1 
  1.  ;   1=different than the previous value
  1.  ;   0=no changes
  1.  ;  -1=new record, no previous values
  1.  ; piece #2 = value before editing if any (current value in DB)
  1.  ; piece #3 = new value
  1.  N CURRVAL S CURRVAL=""
  1.  N STATUS S STATUS=0
  1.  S PSJNEWVL=$G(PSJNEWVL)
  1.  ; if this is non-verified order
  1.  I PSJORD["P" D  Q STATUS_U_$G(CURRVAL)_U_PSJNEWVL
  1.  . ;if node does not exist then return -1
  1.  . I '$D(^PS(53.1,+PSJORD,18)) S STATUS=-1,CURRVAL="" Q
  1.  . S CURRVAL=$$GET1^DIQ(53.1,+PSJORD,132,"E")
  1.  . S STATUS=$S(PSJNEWVL=CURRVAL:0,1:1)
  1.  ; if this is Unit Dose verified order
  1.  I PSJORD["U",+$G(PSJDFN) D  Q STATUS_U_$G(CURRVAL)_U_PSJNEWVL
  1.  . ;if node does not exist then return -1
  1.  . I '$D(^PS(55,+PSJDFN,5,+PSJORD,18)) S STATUS=-1,CURRVAL="" Q
  1.  . S CURRVAL=$$GET1^DIQ(55.06,+PSJORD_","_+PSJDFN_",",141)
  1.  . S STATUS=$S(PSJNEWVL=CURRVAL:0,1:1)
  1.  Q 0  ; there is no difference by default