- 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