PSGOE82 ;BIR/CML - NON-VERIFIED ORDER EDIT (CONT.) ;Oct 14, 2020@16:44:24
;;5.0;INPATIENT MEDICATIONS ;**2,35,50,67,58,81,127,168,181,276,317,366,327,319,411,372**;DEC 97;Build 153
;
; Reference to ^DD(53.1 is supported by DBIA #2256.
; Reference to ^VA(200 is supported by DBIA #10060.
; Reference to ^DIE is supported by DBIA #10018.
; Reference to ^DIC is supported by DBIA #10006.
; Reference to ^DICN is supported by DBIA #10009.
; Reference to $$GET^XPAR is supported by DBIA #2263
; Reference to $$SDEA^XUSER supported by DBIA #2343
;
1 ; provider
S MSG=0,PSGF2=1 S:PSGOEEF(PSGF2) BACK="1^PSGOE82"
A1 I $G(PSGORD)["P",$G(PSGP) I $$LASTREN^PSJLMPRI(PSGP,PSGORD) D Q
. W !?5,"This order has been renewed. Provider may not be edited at this point. " D PAUSE^VALM1
;*366 - check provider credentials
I PSGPR N PSJACT,BKP,BKPN S PSJACT=$$ACTPRO^PSGOE1(PSGPR) I 'PSJACT D
. S BKP=$S($G(PSGPR):$G(PSGPR),1:$G(PSGOPR)),BKPN=$S($L($G(PSGPRN)):$G(PSGPRN),1:$G(PSGOPRN)),PSGPR=0,PSGPRN="",PSJACT="Z"
;; START NCC T4 MODS >> 327*RJS
S PSTMPI=PSGPR,PSTMPN=PSGPRN
A01 ;
W !,"PROVIDER: ",$S(PSGPR:PSGPRN_"// ",1:"") R X:DTIME
I X="^"!'$T W:'$T $C(7) S PSGOEE=0 S:PSJACT="Z" PSGPR=$S($G(BKP):BKUP,1:$G(PSTMPI)),PSGPRN=$S($L($G(BKPN)):BKPN,1:$G(PSTMPN)) G DONE
I $S(X="":'PSGPR,1:X="@") W $C(7)," (Required)" S X="?" D ENHLP^PSGOEM(53.1,1) G A1
I X="",PSGPR S X=PSGPRN I PSGPR'=PSGPRN,$$GET1^DIQ(200,PSGPR,53.1,"I") G:'$G(ANQX) DONE
I +$G(ANQX) G A2
I X?1."?" D ENHLP^PSGOEM(53.1,1)
I $E(X)="^" D ENFF G:Y>0 @Y G A1
K DIC S DIC="^VA(200,",DIC(0)="EMQZ",DIC("S")="I $$ACTPRO^PSGOE1(+Y)" D ^DIC K DIC I Y'>0 G A1
A2 S ANQX=0 D CLOZPRV
I $G(ANQX) S PSGPR=PSTMPI,PSGPRN=PSTMPN K PSTMPN,PSTMPI,ANQX G A1
;; END NCC T4 MODS << 327*RJS
S PSGPR=+Y,PSGPRN=Y(0,0)
;*372
N PSJDEA,PSDEA,PDEA,PSPPKG
I $G(PSGPDRG)]"" D
.S PSPPKG=$S(PSJPROT=1:"U",PSJPROT=3:"UI",1:"") Q:PSPPKG=""
.S PSJDEA=$$OIDEA^PSSOPKI(PSGPDRG,PSPPKG),PSDEA=$P(PSJDEA,";",2) I +PSDEA>=2,+PSDEA<=5 S PDEA=$$SDEA^XUSER(,+PSGPR,PSDEA,,"I")
I ($G(PDEA)=2)!($G(PDEA)=1)!(+$G(PDEA)=4) S PSJACT="Z" D G A01
.W !,"Provider not authorized to prescribe medications in Federal Schedule "_PSDEA_".",!,"Please contact the provider.",!
.S PSGPR=$G(PSTMPI),PSGPRN=$G(PSTMPN)
G DONE
;
5 ; self med
S MSG=0,PSGF2=5 S:PSGOEEF(PSGF2) BACK="5^PSGOE82" K PSGOEEF(6) S:PSGSM PSGOEEF(6)=1
A5 W !,"SELF MED: " W $P("NO^YES","^",PSGSM+1),"// " R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOEE=0 G DONE
;I "01"[X,$L(X)<2 S:PSGSM=""&(X]"") PSGSM=X W:PSGSM]"" " (",$P("NO^YES","^",PSGSM+1),")" G:'PSGSM DONE S PSGOEEF(6)=1 G 6
I "01"[X,$L(X)<2 S:X]"" PSGSM=+X W:PSGSM]"" " (",$P("NO^YES","^",PSGSM+1),")" G:'PSGSM DONE S PSGOEEF(6)=1 G 6
I X="@" W $C(7)," (Required)" G A5
I X?1"^".E D ENFF G:Y>0 @Y G A5
I X?1."?" D ENHLP^PSGOEM(53.1,5) G A5
D YN I S PSGSM=$E(X)="Y" K PSGOEEF(6) G:'PSGSM DONE S PSGOEEF(6)=1 G 6
W $C(7) D ENHLP^PSGOEM(53.1,5) G A5
;
6 ; hospital supplied self med
S MSG=0,PSGF2=6 S:PSGOEEF(PSGF2) BACK="6^PSGOE82"
A6 W !,"HOSPITAL SUPPLIED SELF MED: " W:PSGHSM]"" $P("NO^YES","^",PSGHSM+1),"// " R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOEE=0 G DONE
I "01"[X,$L(X)=1 S:X]"" PSGHSM=+X W " (",$P("NO^YES","^",PSGHSM+1),")" S MSG=0,PSGF2=5 G DONE
I X="@" W $C(7)," (Required)" G A6
I X?1"^".E D ENFF G:Y>0 @Y G A6
I X?1."?" D ENHLP^PSGOEM(53.1,6) G A6
D YN I S PSGHSM=$E(X)="Y" S MSG=0,PSGF2=5 G DONE
W $C(7) D ENHLP^PSGOEM(53.1,6) G A6
;
2 ; dispense drug multiple
;*276 - Disallow unauthorized nurses from editing Dispense Drug
I '$P($G(PSJSYSU),";",4) W !,"You are not authorized to edit Dispense Drugs." D PAUSE^VALM1 Q
S MSG=0,PSGF2=2,BACK="2^PSGOE82" K PSGOEEND
N PSGX,ARRAY D LIST^DIC(53.4502,","_PSJSYSP_",",,"I",,,,,,,"ARRAY") S PSGX=+ARRAY("DILIST",0)
N PSJPNDRN I $G(PSGORD) I $E(PSGORD,$L(PSGORD))="P",$$GET1^DIQ(53.1,+PSGORD,103,"I")="R" S PSJPNDRN=1 D
.S $P(PSJPNDRN,"^",2)="Dispense drugs for renewal orders cannot be deleted, but can be given an INACTIVE DATE. "
; PSJ*5*317 - If PSJ PADE OE BALANCES parameter is YES, PADE balances should display as identifier.
N PSJPADLK S PSJPADLK=0 ; Flag indicating PADE drug lookup was done, don't do drug lookup twice - PSJ*5*317
I $$GET^XPAR("SYS","PSJ PADE OE BALANCES") D
.N DA,DIC,DIE,DR,DIR,PSJLOC,PSJDRG,PSJDDC,DFN,PSJORD,PSJPOI,PSJORCL,PSJCLNK,PSJCLND
.; If clinic order, quit if clinic location is not linked to PADE
.S PSJORCL=$S($G(PSGORD)["P":$$GET1^DIQ(53.1,+$G(PSGORD),113,"I")_"^"_$$GET1^DIQ(53.1,+$G(PSGORD),126,"I"),1:"")
.I PSJORCL,$P(PSJORCL,"^",2) S PSJCLNK=$$PADECL^PSJPAD50(+$G(PSJORCL)) Q:'PSJCLNK
.I '$G(PSJCLNK) Q:'$$PADEWD^PSJPAD50(+$G(VAIN(4)))
.I $G(PSGORD) S PSJPOI=$$GET1^DIQ(53.1,PSGORD,108,"I")
.S DFN=$G(PSGP),PSJORD=$G(PSGORD)
.N ARRAY D LIST^DIC(53.4502,","_+$G(PSJSYSP)_",",,"I",,,,,,,"ARRAY")
.F I=1:1 Q:'$D(ARRAY("DILIST",2,I)) S PSJDDC=ARRAY("DILIST",2,I),PSJDRG(PSJDDC)=$$GET1^DIQ(53.4502,PSJDDC_","_PSJSYSP,.01,"I") I '$G(PSJPOI) D
..S PSJPOI=+$$GET1^DIQ(50,+$G(PSJDRG(PSJDDC)),2.1,"I")
..I '$G(PSJPOI),$G(PSGPD),($$GET1^DIQ(50.7,+$G(PSGPD),.01)]"") S PSJPOI=+PSGPD
.S PSJCLND=$S($G(PSJORD)["U":$$GET1^DIQ(55.06,+PSJORD_","_DFN,28,"I"),$G(PSJORD)["P":$$GET1^DIQ(53.1,+PSGORD,113,"I")_"^"_$$GET1^DIQ(53.1,+PSGORD,126,"I"),1:"")
.S PSJLOC=$S(PSJCLND&$P(PSJCLND,"^",2):+PSJCLND_"C",1:"")
.;S PSJLOC=$S($G(PSJORD)["U":+$G(^PS(55,DFN,5,+PSJORD,8))_"C",$G(PSJORD)["P":+$G(^PS(53.1,+PSJORD,"DSS"))_"C",1:"")
.S:'PSJLOC PSJLOC=+$G(VAIN(4)) I '$G(PSJLOC) D
..N VAIN D INP^VADPT S PSJLOC=$G(VAIN(4))
.S PSJPADLK=1
.D READDD^PSJPAD50(.PSJDRG,$S($G(PSGPD):+$G(PSGPD),1:+$G(PSJPOI)),PSJLOC,PSJORD,$G(PSGORD))
; PSJ*5*317 - If PSJ PADE OE BALANCES parameter is NO, PADE balances should NOT display as identifer.
I '$G(PSJPADLK) N DA,DIC,DIE,DR,DIR S DIE="^PS(53.45,",DA=PSJSYSP,DR=2,DR(2,53.4502)=".01;.02"_$S($G(PSJPNDRN):";.03",1:"") D ^DIE
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!",! S MSG=1
D DDOC(PSGX)
NEW PSJDOSE
D DOSECHK^PSJDOSE
I +$G(PSJDSFLG) D DSPWARN^PSJDOSE S PSGOEEF(109)=1
G DONE
;
40 ; comments
S MSG=0,PSGF2=40,BACK="40^PSGOE82",DA=PSJSYSP,DR=1,DIE="^PS(53.45," D ^DIE W ! G DONE
;
66 ; provider comments
;S MSG=0,PSGF2=66,BACK="66^PSGOE82",DA=PSJSYSP,DR=4,DIE="^PS(53.45," D ^DIE W ! G DONE
;
DONE ;
I PSGOEE G:'PSGOEEF(PSGF2) @BACK S PSGOEE=PSGOEEF(PSGF2)
K F,F0,PSGF2,F3,PSG,SDT Q
;
ENFF ; up-arrow to another field
S Y=-1 I '$D(PSGOEEF)!(X?1"^"1.9N) W $C(7)," ??" Q
S X=$E(X,2,99) I X=+X S Y=$S($D(PSGOEEF(X)):X,1:-1) W " " W:Y>0 $$CODES2^PSIVUTL(53.1,X) W:Y'>0 $C(7),"??" Q
K DIC S DIC="^DD(53.1,",DIC(0)="QEM",DIC("S")="I $D(PSGOEEF(+Y))" D ^DIC K DIC S Y=+Y S:Y>0 Y=$P($T(@("F"_Y)),";",3) Q
;
DEL ; delete entry
W !?3,"SURE YOU WANT TO DELETE" S %=0 D YN^DICN I %'=1 W $C(7)," <NOTHING DELETED>"
Q
;
CLOZPRV ;; START NCC T4 MODS >> 327*RJS
N CLOZFLG I $G(PSGORD)["P",$$GET1^DIQ(53.1,+PSGORD,.01) S CLOZFLG=$$ISCLOZ^PSJCLOZ(+PSGORD) I 1
E I $G(PSGORD),$$GET1^DIQ(55.06,+PSGORD_","_PSGP,.01) S CLOZFLG=$$ISCLOZ^PSJCLOZ(,,PSGP,+PSGORD) I 1
E S CLOZFLG=$$ISCLOZ^PSJCLOZ(,,,+$G(PSGDRG))
I CLOZFLG D
.I PSGPR'=+Y S PSGPR=+Y,PSGPRN=Y(0,0)
.S ANQX=0 D PROVCHK^PSJCLOZ(PSGPR)
.I ANQX=0 K PSTMPN,PSTMPI
;; END NCC T4 MODS << 327*RJS
Q
;
YN ; yes/no as a set of codes
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))
F Y="NO","YES" I $P(Y,X)="" W $P(Y,X,2) Q
Q
DDOC(PSGX) ; Order check on additional dispense drug for allergy and adv. reactions.
N PSGY,PSGND1,PSGND3,PSJALLGY
S PSGY=0 F S PSGX=$O(^PS(53.45,PSJSYSP,2,PSGX)) Q:'PSGX S PSGY=$P($G(^PS(53.45,PSJSYSP,2,PSGX,0)),"^") Q:PSGY="" D
. N INTERVEN,PSJDDI,PSJIREQ,PSJRXREQ,PSJDD,PSGORQF,PSJPDRG S PSJDD=PSGY
. S Y=1,(PSJIREQ,PSJRXREQ,INTERVEN,X)=""
. I '$G(PSJALGY1) S PSJALLGY(PSJDD)="" D ALLERGY^PSJOC
. ;D IVSOL^PSGSICHK
. I ($D(PSGORQF)) D
.. K ^PS(53.45,PSJSYSP,2,PSGX),^PS(53.45,PSJSYSP,2,"B",PSGY)
Q
;
50 N DIR,X,Y,CLN
S MSG=0,PSGF2=50 S:$G(PSGOEEF(PSGF2)) BACK="50^PSGOE82"
S DIR(0)="P^44:EMZ",DIR("A")="Visit Location",DIR("S")="I $P($G(^SC(Y,0)),U,3)=""C"",$$ACTLOC^PSJOE1(Y),$$IMOLOC^PSJOE1(Y,$G(PSGP))>-1"
S CLN=$S($G(PSJCLAPP):+PSJCLAPP,$G(P("CLIN")):P("CLIN"),1:0) I CLN S DIR("B")=$P(^SC(CLN,0),U)
D ^DIR
I $D(DIRUT) S PSGOEE=0 G DONE
S $P(PSJCLAPP,"^")=+Y,P("CLIN")=+Y
I '$G(PSGOEEF(+PSGF2)) S PSGOEE=0
G DONE
;
51 N %DT,X,Y,CLNDT
S MSG=0,PSGF2=51 S:$G(PSGOEEF(PSGF2)) BACK="51^PSGOE82"
K %DT
S %DT("A")="Date/Time of Visit: ",%DT="AER"
S Y=$S($P($G(PSJCLAPP),"^",2):$P(PSJCLAPP,"^",2),$G(P("APPT")):P("APPT"),1:"")
I Y'="" X ^DD("DD") S %DT("B")=Y
X ^DD("DD")
D ^%DT
I Y<0!($D(DTOUT)) S PSGOEE=0 G DONE
S $P(PSJCLAPP,"^",2)=+Y,P("APPT")=+Y
K %DT
I '$G(PSGOEEF(+PSGF2)) S PSGOEE=0
G DONE
;
F101 ;;101^PSGOE8
F109 ;;109^PSGOE8
F3 ;;3^PSGOE8
F7 ;;7^PSGOE8
PSGF26 ;;26^PSGOE8
F39 ;;39^PSGOE81
F8 ;;8^PSGOE81
F10 ;;10^PSGOE81
PSGF25 ;;25^PSGOE81
F1 ;;1^PSGOE82
F5 ;;5^PSGOE82
PSGF2 ;;2^PSGOE82
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGOE82 9167 printed Mar 13, 2025@21:06:53 Page 2
PSGOE82 ;BIR/CML - NON-VERIFIED ORDER EDIT (CONT.) ;Oct 14, 2020@16:44:24
+1 ;;5.0;INPATIENT MEDICATIONS ;**2,35,50,67,58,81,127,168,181,276,317,366,327,319,411,372**;DEC 97;Build 153
+2 ;
+3 ; Reference to ^DD(53.1 is supported by DBIA #2256.
+4 ; Reference to ^VA(200 is supported by DBIA #10060.
+5 ; Reference to ^DIE is supported by DBIA #10018.
+6 ; Reference to ^DIC is supported by DBIA #10006.
+7 ; Reference to ^DICN is supported by DBIA #10009.
+8 ; Reference to $$GET^XPAR is supported by DBIA #2263
+9 ; Reference to $$SDEA^XUSER supported by DBIA #2343
+10 ;
1 ; provider
+1 SET MSG=0
SET PSGF2=1
if PSGOEEF(PSGF2)
SET BACK="1^PSGOE82"
A1 IF $GET(PSGORD)["P"
IF $GET(PSGP)
IF $$LASTREN^PSJLMPRI(PSGP,PSGORD)
Begin DoDot:1
+1 WRITE !?5,"This order has been renewed. Provider may not be edited at this point. "
DO PAUSE^VALM1
End DoDot:1
QUIT
+2 ;*366 - check provider credentials
+3 IF PSGPR
NEW PSJACT,BKP,BKPN
SET PSJACT=$$ACTPRO^PSGOE1(PSGPR)
IF 'PSJACT
Begin DoDot:1
+4 SET BKP=$SELECT($GET(PSGPR):$GET(PSGPR),1:$GET(PSGOPR))
SET BKPN=$SELECT($LENGTH($GET(PSGPRN)):$GET(PSGPRN),1:$GET(PSGOPRN))
SET PSGPR=0
SET PSGPRN=""
SET PSJACT="Z"
End DoDot:1
+5 ;; START NCC T4 MODS >> 327*RJS
+6 SET PSTMPI=PSGPR
SET PSTMPN=PSGPRN
A01 ;
+1 WRITE !,"PROVIDER: ",$SELECT(PSGPR:PSGPRN_"// ",1:"")
READ X:DTIME
+2 IF X="^"!'$TEST
if '$TEST
WRITE $CHAR(7)
SET PSGOEE=0
if PSJACT="Z"
SET PSGPR=$SELECT($GET(BKP):BKUP,1:$GET(PSTMPI))
SET PSGPRN=$SELECT($LENGTH($GET(BKPN)):BKPN,1:$GET(PSTMPN))
GOTO DONE
+3 IF $SELECT(X="":'PSGPR,1:X="@")
WRITE $CHAR(7)," (Required)"
SET X="?"
DO ENHLP^PSGOEM(53.1,1)
GOTO A1
+4 IF X=""
IF PSGPR
SET X=PSGPRN
IF PSGPR'=PSGPRN
IF $$GET1^DIQ(200,PSGPR,53.1,"I")
if '$GET(ANQX)
GOTO DONE
+5 IF +$GET(ANQX)
GOTO A2
+6 IF X?1."?"
DO ENHLP^PSGOEM(53.1,1)
+7 IF $EXTRACT(X)="^"
DO ENFF
if Y>0
GOTO @Y
GOTO A1
+8 KILL DIC
SET DIC="^VA(200,"
SET DIC(0)="EMQZ"
SET DIC("S")="I $$ACTPRO^PSGOE1(+Y)"
DO ^DIC
KILL DIC
IF Y'>0
GOTO A1
A2 SET ANQX=0
DO CLOZPRV
+1 IF $GET(ANQX)
SET PSGPR=PSTMPI
SET PSGPRN=PSTMPN
KILL PSTMPN,PSTMPI,ANQX
GOTO A1
+2 ;; END NCC T4 MODS << 327*RJS
+3 SET PSGPR=+Y
SET PSGPRN=Y(0,0)
+4 ;*372
+5 NEW PSJDEA,PSDEA,PDEA,PSPPKG
+6 IF $GET(PSGPDRG)]""
Begin DoDot:1
+7 SET PSPPKG=$SELECT(PSJPROT=1:"U",PSJPROT=3:"UI",1:"")
if PSPPKG=""
QUIT
+8 SET PSJDEA=$$OIDEA^PSSOPKI(PSGPDRG,PSPPKG)
SET PSDEA=$PIECE(PSJDEA,";",2)
IF +PSDEA>=2
IF +PSDEA<=5
SET PDEA=$$SDEA^XUSER(,+PSGPR,PSDEA,,"I")
End DoDot:1
+9 IF ($GET(PDEA)=2)!($GET(PDEA)=1)!(+$GET(PDEA)=4)
SET PSJACT="Z"
Begin DoDot:1
+10 WRITE !,"Provider not authorized to prescribe medications in Federal Schedule "_PSDEA_".",!,"Please contact the provider.",!
+11 SET PSGPR=$GET(PSTMPI)
SET PSGPRN=$GET(PSTMPN)
End DoDot:1
GOTO A01
+12 GOTO DONE
+13 ;
5 ; self med
+1 SET MSG=0
SET PSGF2=5
if PSGOEEF(PSGF2)
SET BACK="5^PSGOE82"
KILL PSGOEEF(6)
if PSGSM
SET PSGOEEF(6)=1
A5 WRITE !,"SELF MED: "
WRITE $PIECE("NO^YES","^",PSGSM+1),"// "
READ X:DTIME
IF X="^"!'$TEST
if '$TEST
WRITE $CHAR(7)
SET PSGOEE=0
GOTO DONE
+1 ;I "01"[X,$L(X)<2 S:PSGSM=""&(X]"") PSGSM=X W:PSGSM]"" " (",$P("NO^YES","^",PSGSM+1),")" G:'PSGSM DONE S PSGOEEF(6)=1 G 6
+2 IF "01"[X
IF $LENGTH(X)<2
if X]""
SET PSGSM=+X
if PSGSM]""
WRITE " (",$PIECE("NO^YES","^",PSGSM+1),")"
if 'PSGSM
GOTO DONE
SET PSGOEEF(6)=1
GOTO 6
+3 IF X="@"
WRITE $CHAR(7)," (Required)"
GOTO A5
+4 IF X?1"^".E
DO ENFF
if Y>0
GOTO @Y
GOTO A5
+5 IF X?1."?"
DO ENHLP^PSGOEM(53.1,5)
GOTO A5
+6 DO YN
IF $TEST
SET PSGSM=$EXTRACT(X)="Y"
KILL PSGOEEF(6)
if 'PSGSM
GOTO DONE
SET PSGOEEF(6)=1
GOTO 6
+7 WRITE $CHAR(7)
DO ENHLP^PSGOEM(53.1,5)
GOTO A5
+8 ;
6 ; hospital supplied self med
+1 SET MSG=0
SET PSGF2=6
if PSGOEEF(PSGF2)
SET BACK="6^PSGOE82"
A6 WRITE !,"HOSPITAL SUPPLIED SELF MED: "
if PSGHSM]""
WRITE $PIECE("NO^YES","^",PSGHSM+1),"// "
READ X:DTIME
IF X="^"!'$TEST
if '$TEST
WRITE $CHAR(7)
SET PSGOEE=0
GOTO DONE
+1 IF "01"[X
IF $LENGTH(X)=1
if X]""
SET PSGHSM=+X
WRITE " (",$PIECE("NO^YES","^",PSGHSM+1),")"
SET MSG=0
SET PSGF2=5
GOTO DONE
+2 IF X="@"
WRITE $CHAR(7)," (Required)"
GOTO A6
+3 IF X?1"^".E
DO ENFF
if Y>0
GOTO @Y
GOTO A6
+4 IF X?1."?"
DO ENHLP^PSGOEM(53.1,6)
GOTO A6
+5 DO YN
IF $TEST
SET PSGHSM=$EXTRACT(X)="Y"
SET MSG=0
SET PSGF2=5
GOTO DONE
+6 WRITE $CHAR(7)
DO ENHLP^PSGOEM(53.1,6)
GOTO A6
+7 ;
2 ; dispense drug multiple
+1 ;*276 - Disallow unauthorized nurses from editing Dispense Drug
+2 IF '$PIECE($GET(PSJSYSU),";",4)
WRITE !,"You are not authorized to edit Dispense Drugs."
DO PAUSE^VALM1
QUIT
+3 SET MSG=0
SET PSGF2=2
SET BACK="2^PSGOE82"
KILL PSGOEEND
+4 NEW PSGX,ARRAY
DO LIST^DIC(53.4502,","_PSJSYSP_",",,"I",,,,,,,"ARRAY")
SET PSGX=+ARRAY("DILIST",0)
+5 NEW PSJPNDRN
IF $GET(PSGORD)
IF $EXTRACT(PSGORD,$LENGTH(PSGORD))="P"
IF $$GET1^DIQ(53.1,+PSGORD,103,"I")="R"
SET PSJPNDRN=1
Begin DoDot:1
+6 SET $PIECE(PSJPNDRN,"^",2)="Dispense drugs for renewal orders cannot be deleted, but can be given an INACTIVE DATE. "
End DoDot:1
+7 ; PSJ*5*317 - If PSJ PADE OE BALANCES parameter is YES, PADE balances should display as identifier.
+8 ; Flag indicating PADE drug lookup was done, don't do drug lookup twice - PSJ*5*317
NEW PSJPADLK
SET PSJPADLK=0
+9 IF $$GET^XPAR("SYS","PSJ PADE OE BALANCES")
Begin DoDot:1
+10 NEW DA,DIC,DIE,DR,DIR,PSJLOC,PSJDRG,PSJDDC,DFN,PSJORD,PSJPOI,PSJORCL,PSJCLNK,PSJCLND
+11 ; If clinic order, quit if clinic location is not linked to PADE
+12 SET PSJORCL=$SELECT($GET(PSGORD)["P":$$GET1^DIQ(53.1,+$GET(PSGORD),113,"I")_"^"_$$GET1^DIQ(53.1,+$GET(PSGORD),126,"I"),1:"")
+13 IF PSJORCL
IF $PIECE(PSJORCL,"^",2)
SET PSJCLNK=$$PADECL^PSJPAD50(+$GET(PSJORCL))
if 'PSJCLNK
QUIT
+14 IF '$GET(PSJCLNK)
if '$$PADEWD^PSJPAD50(+$GET(VAIN(4)))
QUIT
+15 IF $GET(PSGORD)
SET PSJPOI=$$GET1^DIQ(53.1,PSGORD,108,"I")
+16 SET DFN=$GET(PSGP)
SET PSJORD=$GET(PSGORD)
+17 NEW ARRAY
DO LIST^DIC(53.4502,","_+$GET(PSJSYSP)_",",,"I",,,,,,,"ARRAY")
+18 FOR I=1:1
if '$DATA(ARRAY("DILIST",2,I))
QUIT
SET PSJDDC=ARRAY("DILIST",2,I)
SET PSJDRG(PSJDDC)=$$GET1^DIQ(53.4502,PSJDDC_","_PSJSYSP,.01,"I")
IF '$GET(PSJPOI)
Begin DoDot:2
+19 SET PSJPOI=+$$GET1^DIQ(50,+$GET(PSJDRG(PSJDDC)),2.1,"I")
+20 IF '$GET(PSJPOI)
IF $GET(PSGPD)
IF ($$GET1^DIQ(50.7,+$GET(PSGPD),.01)]"")
SET PSJPOI=+PSGPD
End DoDot:2
+21 SET PSJCLND=$SELECT($GET(PSJORD)["U":$$GET1^DIQ(55.06,+PSJORD_","_DFN,28,"I"),$GET(PSJORD)["P":$$GET1^DIQ(53.1,+PSGORD,113,"I")_"^"_$$GET1^DIQ(53.1,+PSGORD,126,"I"),1:"")
+22 SET PSJLOC=$SELECT(PSJCLND&$PIECE(PSJCLND,"^",2):+PSJCLND_"C",1:"")
+23 ;S PSJLOC=$S($G(PSJORD)["U":+$G(^PS(55,DFN,5,+PSJORD,8))_"C",$G(PSJORD)["P":+$G(^PS(53.1,+PSJORD,"DSS"))_"C",1:"")
+24 if 'PSJLOC
SET PSJLOC=+$GET(VAIN(4))
IF '$GET(PSJLOC)
Begin DoDot:2
+25 NEW VAIN
DO INP^VADPT
SET PSJLOC=$GET(VAIN(4))
End DoDot:2
+26 SET PSJPADLK=1
+27 DO READDD^PSJPAD50(.PSJDRG,$SELECT($GET(PSGPD):+$GET(PSGPD),1:+$GET(PSJPOI)),PSJLOC,PSJORD,$GET(PSGORD))
End DoDot:1
+28 ; PSJ*5*317 - If PSJ PADE OE BALANCES parameter is NO, PADE balances should NOT display as identifer.
+29 IF '$GET(PSJPADLK)
NEW DA,DIC,DIE,DR,DIR
SET DIE="^PS(53.45,"
SET DA=PSJSYSP
SET DR=2
SET DR(2,53.4502)=".01;.02"_$SELECT($GET(PSJPNDRN):";.03",1:"")
DO ^DIE
+30 IF '$ORDER(^PS(53.45,PSJSYSP,2,0))
WRITE $CHAR(7),!!,"WARNING: This order must have at least one dispense drug before pharmacy can",!?9,"verify it!",!
SET MSG=1
+31 DO DDOC(PSGX)
+32 NEW PSJDOSE
+33 DO DOSECHK^PSJDOSE
+34 IF +$GET(PSJDSFLG)
DO DSPWARN^PSJDOSE
SET PSGOEEF(109)=1
+35 GOTO DONE
+36 ;
40 ; comments
+1 SET MSG=0
SET PSGF2=40
SET BACK="40^PSGOE82"
SET DA=PSJSYSP
SET DR=1
SET DIE="^PS(53.45,"
DO ^DIE
WRITE !
GOTO DONE
+2 ;
66 ; provider comments
+1 ;S MSG=0,PSGF2=66,BACK="66^PSGOE82",DA=PSJSYSP,DR=4,DIE="^PS(53.45," D ^DIE W ! G DONE
+2 ;
DONE ;
+1 IF PSGOEE
if 'PSGOEEF(PSGF2)
GOTO @BACK
SET PSGOEE=PSGOEEF(PSGF2)
+2 KILL F,F0,PSGF2,F3,PSG,SDT
QUIT
+3 ;
ENFF ; up-arrow to another field
+1 SET Y=-1
IF '$DATA(PSGOEEF)!(X?1"^"1.9N)
WRITE $CHAR(7)," ??"
QUIT
+2 SET X=$EXTRACT(X,2,99)
IF X=+X
SET Y=$SELECT($DATA(PSGOEEF(X)):X,1:-1)
WRITE " "
if Y>0
WRITE $$CODES2^PSIVUTL(53.1,X)
if Y'>0
WRITE $CHAR(7),"??"
QUIT
+3 KILL DIC
SET DIC="^DD(53.1,"
SET DIC(0)="QEM"
SET DIC("S")="I $D(PSGOEEF(+Y))"
DO ^DIC
KILL DIC
SET Y=+Y
if Y>0
SET Y=$PIECE($TEXT(@("F"_Y)),";",3)
QUIT
+4 ;
DEL ; delete entry
+1 WRITE !?3,"SURE YOU WANT TO DELETE"
SET %=0
DO YN^DICN
IF %'=1
WRITE $CHAR(7)," <NOTHING DELETED>"
+2 QUIT
+3 ;
CLOZPRV ;; START NCC T4 MODS >> 327*RJS
+1 NEW CLOZFLG
IF $GET(PSGORD)["P"
IF $$GET1^DIQ(53.1,+PSGORD,.01)
SET CLOZFLG=$$ISCLOZ^PSJCLOZ(+PSGORD)
IF 1
+2 IF '$TEST
IF $GET(PSGORD)
IF $$GET1^DIQ(55.06,+PSGORD_","_PSGP,.01)
SET CLOZFLG=$$ISCLOZ^PSJCLOZ(,,PSGP,+PSGORD)
IF 1
+3 IF '$TEST
SET CLOZFLG=$$ISCLOZ^PSJCLOZ(,,,+$GET(PSGDRG))
+4 IF CLOZFLG
Begin DoDot:1
+5 IF PSGPR'=+Y
SET PSGPR=+Y
SET PSGPRN=Y(0,0)
+6 SET ANQX=0
DO PROVCHK^PSJCLOZ(PSGPR)
+7 IF ANQX=0
KILL PSTMPN,PSTMPI
End DoDot:1
+8 ;; END NCC T4 MODS << 327*RJS
+9 QUIT
+10 ;
YN ; yes/no as a set of codes
+1 IF X'?.U
FOR Y=1:1:$LENGTH(X)
IF $EXTRACT(X,Y)?1L
SET X=$EXTRACT(X,1,Y-1)_$CHAR($ASCII(X,Y)-32)_$EXTRACT(X,Y+1,$LENGTH(X))
+2 FOR Y="NO","YES"
IF $PIECE(Y,X)=""
WRITE $PIECE(Y,X,2)
QUIT
+3 QUIT
DDOC(PSGX) ; Order check on additional dispense drug for allergy and adv. reactions.
+1 NEW PSGY,PSGND1,PSGND3,PSJALLGY
+2 SET PSGY=0
FOR
SET PSGX=$ORDER(^PS(53.45,PSJSYSP,2,PSGX))
if 'PSGX
QUIT
SET PSGY=$PIECE($GET(^PS(53.45,PSJSYSP,2,PSGX,0)),"^")
if PSGY=""
QUIT
Begin DoDot:1
+3 NEW INTERVEN,PSJDDI,PSJIREQ,PSJRXREQ,PSJDD,PSGORQF,PSJPDRG
SET PSJDD=PSGY
+4 SET Y=1
SET (PSJIREQ,PSJRXREQ,INTERVEN,X)=""
+5 IF '$GET(PSJALGY1)
SET PSJALLGY(PSJDD)=""
DO ALLERGY^PSJOC
+6 ;D IVSOL^PSGSICHK
+7 IF ($DATA(PSGORQF))
Begin DoDot:2
+8 KILL ^PS(53.45,PSJSYSP,2,PSGX),^PS(53.45,PSJSYSP,2,"B",PSGY)
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
50 NEW DIR,X,Y,CLN
+1 SET MSG=0
SET PSGF2=50
if $GET(PSGOEEF(PSGF2))
SET BACK="50^PSGOE82"
+2 SET DIR(0)="P^44:EMZ"
SET DIR("A")="Visit Location"
SET DIR("S")="I $P($G(^SC(Y,0)),U,3)=""C"",$$ACTLOC^PSJOE1(Y),$$IMOLOC^PSJOE1(Y,$G(PSGP))>-1"
+3 SET CLN=$SELECT($GET(PSJCLAPP):+PSJCLAPP,$GET(P("CLIN")):P("CLIN"),1:0)
IF CLN
SET DIR("B")=$PIECE(^SC(CLN,0),U)
+4 DO ^DIR
+5 IF $DATA(DIRUT)
SET PSGOEE=0
GOTO DONE
+6 SET $PIECE(PSJCLAPP,"^")=+Y
SET P("CLIN")=+Y
+7 IF '$GET(PSGOEEF(+PSGF2))
SET PSGOEE=0
+8 GOTO DONE
+9 ;
51 NEW %DT,X,Y,CLNDT
+1 SET MSG=0
SET PSGF2=51
if $GET(PSGOEEF(PSGF2))
SET BACK="51^PSGOE82"
+2 KILL %DT
+3 SET %DT("A")="Date/Time of Visit: "
SET %DT="AER"
+4 SET Y=$SELECT($PIECE($GET(PSJCLAPP),"^",2):$PIECE(PSJCLAPP,"^",2),$GET(P("APPT")):P("APPT"),1:"")
+5 IF Y'=""
XECUTE ^DD("DD")
SET %DT("B")=Y
+6 XECUTE ^DD("DD")
+7 DO ^%DT
+8 IF Y<0!($DATA(DTOUT))
SET PSGOEE=0
GOTO DONE
+9 SET $PIECE(PSJCLAPP,"^",2)=+Y
SET P("APPT")=+Y
+10 KILL %DT
+11 IF '$GET(PSGOEEF(+PSGF2))
SET PSGOEE=0
+12 GOTO DONE
+13 ;
F101 ;;101^PSGOE8
F109 ;;109^PSGOE8
F3 ;;3^PSGOE8
F7 ;;7^PSGOE8
PSGF26 ;;26^PSGOE8
F39 ;;39^PSGOE81
F8 ;;8^PSGOE81
F10 ;;10^PSGOE81
PSGF25 ;;25^PSGOE81
F1 ;;1^PSGOE82
F5 ;;5^PSGOE82
PSGF2 ;;2^PSGOE82
