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

PSJOE1.m

Go to the documentation of this file.
  1. PSJOE1 ;BIR/CML - UD OE FOR COMBINED OE; Oct 14, 2020@10:48
  1. ;;5.0;INPATIENT MEDICATIONS;**2,7,25,30,47,56,64,179,181,252,281,315,338,373,353,327,319,411,399,448**;16 DEC 97;Build 1
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;Reference to ^DICN in ICR #10009
  1. ;Reference to ^VALM in ICR #10118
  1. ;Reference to ^TMP("PSODAOC",$J) in ICR #6071
  1. ;Reference to ^SC in ICR #10040
  1. ;
  1. ;*353 Haz Meds cleanup var
  1. ;
  1. S PC=0 G AD
  1. ;
  1. CM ; Ask Clinic - Clinic Medication Order ;*p319
  1. K DIRUT,PSJCLAPP,DIR,X,Y
  1. D FULL^VALM1
  1. W !
  1. S DIR(0)="PO^44:EMZ",DIR("A")="Visit Location"
  1. I $G(P("CLIN")) S DIR("B")=$P(^SC(+P("CLIN"),0),"^"),PSJCLAPP=P("CLIN")
  1. S DIR("S")="I $P($G(^SC(Y,0)),U,3)=""C"",$$ACTLOC^PSJOE1(Y),$$IMOLOC^PSJOE1(Y,$G(PSGP))>-1"
  1. D ^DIR K DIR
  1. I +Y<1 S PSJCM01=-1 Q
  1. S PSJCLAPP=+Y
  1. D SVST Q:$P(PSJCLAPP,"^",2) Q:$G(PSGORQF)
  1. ; Ask for Visit Date/Time ;*p319
  1. K %DT
  1. I $G(P("APPT")) S Y=P("APPT") D DD^%DT I Y'="" S %DT("B")=Y
  1. S %DT("A")="Date/Time of Visit: ",%DT="RAE",%DT("B")=$S($G(%DT("B"))'="":%DT("B"),1:"NOW")
  1. D ^%DT I Y<0!($D(DTOUT)) S PSJCM01=-1 Q
  1. S $P(PSJCLAPP,"^",2)=+Y
  1. K %DT
  1. Q
  1. SVST ;get scheduled/new visits ;*p319
  1. N PSJVST,XX,YY,C,DIR,X,Y,X1,X2,APTMIN,APTMAX,STDT,ENDT,PVST,VST
  1. S APTMIN=$$GET1^DIQ(53.46,+PSJCLAPP,8,"I")
  1. S APTMAX=$$GET1^DIQ(53.46,+PSJCLAPP,9,"I")
  1. S X1=DT,X2=$S(APTMIN:-APTMIN,1:-90) D C^%DTC S STDT=X
  1. S X1=DT,X2=$S(APTMAX:APTMAX,1:365) D C^%DTC S ENDT=X
  1. D VST^ORWCV(.PSJVST,$G(PSGP),STDT,ENDT,1)
  1. Q:'$D(PSJVST)
  1. S (XX,C)=0 F S XX=$O(PSJVST(XX)) Q:'XX S YY=PSJVST(XX) I $P($P(YY,"^"),";",3)=+PSJCLAPP D
  1. .S C=C+1,PSJVIS(C)=$P(YY,"^",3)_"^"_$$FMTE^XLFDT($P(YY,"^",2))_"^"_$P(YY,"^",4)_"^"_$P(YY,"^",2)
  1. Q:C<1
  1. S C=C+1,PSJVIS(C)="New Visit"
  1. V1 W !!?4,"Scheduled Clinic Appointment (",$$FMTE^XLFDT(STDT)," thru ",$$FMTE^XLFDT(ENDT),")"
  1. F I=1:1 S XX=$O(PSJVIS(XX)) Q:'XX S YY=PSJVIS(XX) W !,I,". ",$P(YY,"^"),?35,$$FMTE^XLFDT($P(YY,"^",2)),?55,$P(YY,"^",3)
  1. K DIR S DIR(0)="N^1:"_C
  1. S DIR("A")="Select Visit" D ^DIR
  1. I $D(DIRUT) S PSGORQF=1,PSJCM01=-1 Q
  1. Q:Y=C
  1. S VST=Y
  1. I $$FMDIFF^XLFDT($P(PSJVIS(Y),"^",4),DT,1)<0 S PVST=$$PVST() Q:PVST=-1 G:PVST V1
  1. S $P(PSJCLAPP,"^",2)=$P(PSJVIS(VST),"^",4) W !,"Date/Time of Visit: ",$P(PSJVIS(VST),"^",2)
  1. Q
  1. PVST() ;ask about past visit
  1. N DIR
  1. S DIR(0)="Y"
  1. S DIR("A")="You currently have a past date selected for this visit. Do you want to select a current date"
  1. D ^DIR
  1. I $D(DIRUT) S PSGORQF=1,PSJCM01=-1 Q -1
  1. Q Y
  1. ;
  1. EN ;
  1. S PC=0
  1. ;
  1. ;PSJOCFG - If defined, it's for new order, renew or copy. ^PSJOCDSD using this flag to not display drug error.
  1. K PSJOCFG,PSGDUR,PSGRMVT,PSGRMV,PSGRF,ND2P1,ANQX ;*315
  1. K PSGDRG,PSGDRGN ;*353
  1. N PSJNORD,PSGORQF,PSGSDX,PSGFDX,PSGNEFDO,PSGEDTOI,PSJOCFG,PSGDREQ S PSJOCFG="NEW UD" S PSJNORD=1 I $D(VALM("TM")) S IOTM=VALM("TM"),IOBM=IOSL W IOSC,@IOSTBM,IORC
  1. K PSGORQF
  1. I $D(PSJCMO)!$D(PSJCM01),$G(PSJCMF) D CM I $G(PSJCM01)=-1 G DONE ;*p319
  1. D ^PSGOE7
  1. I +$G(PSJCLAPP) S PSJCMF=1 ;p319 Clinic Order - Flag to display
  1. I $G(PSGORQF) S PSJORQF=1 G DONE
  1. S PC=1,PSJORQF=0 I X?1"S."1.E D ^PSGOES G AD
  1. D ^PSGOE4:'$P(PSJSYSP0,"^",12),^PSGOE3:$P(PSJSYSP0,"^",12)
  1. G:$G(PSGOROE1)=1 AD
  1. K PSGEFN,PSGOEEF,PSGOEE,PSGOEOS S PSGEFN="1:14" F X=1:1:14 S PSGEFN(X)=""
  1. I $G(PSJCMO)!$G(PSJCM01) S PSGEFN="1:16" F X=15,16 S PSGEFN(X)="" ;p319
  1. S PSGPDN=$$OINAME^PSJLMUTL(PSGPDRG),PSGPD=PSGPDRG,PSGOINST="",PSGSDN=$$ENDD^PSGMI(PSGNESD)_U_$$ENDTC^PSGMI(PSGNESD),PSGFDN=$$ENDD^PSGMI(PSGNEFD)_U_$$ENDTC^PSGMI(PSGNEFD)
  1. S:$D(PSJOCFG) PSGSDN=$$ENDD^PSGMI(PSGNESD)_U_$$ENDTC2^PSGMI(PSGNESD),PSGFDN=$$ENDD^PSGMI(PSGNEFD)_U_$$ENDTC2^PSGMI(PSGNEFD) ;#373
  1. S PSGAT=PSGS0Y,PSGLIN=$$ENDD^PSGMI(PSGDT)_U_$$ENDTC^PSGMI(PSGDT),PSGLI=PSGDT,PSGEBN=$$ENNPN^PSGMI(DUZ),PSGSTAT=$S(PSGOEAV:"ACTIVE",1:"NON-VERIFIED")
  1. D CHK^PSGOEV("^^"_PSGMR_"^^^^"_PSGST,PSGPDRG_U_PSGDO,PSGSCH_U_PSGNESD_"^^"_PSGNEFD)
  1. S PSGSD=PSGNESD,PSGFD=PSGNEFD
  1. K PSJACEPT S VALMBCK="Q" D:$D(Y) EN^VALM("PSJU LM ACCEPT")
  1. I $G(PSJACEPT)=1 D I $G(ANQX) D DONE G AD
  1. . D OC
  1. . ;D:'$G(PSGORQF) IN^PSJOCDS($G(PSGORD),"UD",+$G(PSGDRG))
  1. ;If intervention is not log then quit
  1. I $G(PSGORQF)=1 S PSJACEPT=0
  1. S PSJNOO=-1 I $G(PSJACEPT)=1 S PSJNOO=$$ENNOO^PSJUTL5("N")
  1. I $G(PSJNOO)<0 D
  1. . I $$ISCLOZ^PSJCLOZ(,PSGPD) K ^XTMP("PSJ4D-"_$G(DFN)) ;p327
  1. I $G(PSJNOO)<0 K PSJACEPT,PSJCLAPP W !,"No order created." G AD
  1. K PSGOEE D ^PSGOETO S PSJORD=PSGORD
  1. S ^TMP("PSODAOC",$J,"IP IEN")=PSGORD
  1. I $G(PSODAND) S ^TMP("PSJCOM",$J,+PSGORD,"SAND")=PSODAND
  1. ;RTC 178746 - Don't store allergy here.
  1. ;D SETOC^PSJNEWOC(PSGORD)
  1. I PSGOEAV D G AD
  1. .;; START NCC REMEDIATION >> 327*RJS
  1. .I $$ISCLOZ^PSJCLOZ(,PSGPD) D
  1. ..N DIE,DA,DR S DIE="^PS(55,"_PSGP_",5,",DA=+$G(PSGORD),DA(1)=PSGP,DR="301////"
  1. ..I $G(PSGNTDD) S DR=DR_PSGNTDD
  1. ..E I $G(PSGETDD) S DR=DR_PSGETDD
  1. ..E I $G(PSGCTDD) S DR=DR_PSGCTDD
  1. ..E I $D(^TMP($J,"PSGCLOZ",PSGP,+$G(PSGORD),"SAND")) S DR=DR_$G(^TMP($J,"PSGCLOZ",PSGP,+$G(PSGORD),"SAND")) K ^TMP($J,"PSGCLOZ",PSGP,+$G(PSGORD),"SAND")
  1. ..D ^DIE
  1. ..D CLOZSND^PSJOE ; SEND OVERRIDE MESSAGE & XTMP TRANSACTION DATA
  1. .;; END NCC REMEDIATION >> 327*RJS
  1. . D SETOC^PSJNEWOC(PSGORD) ;RTC 17874
  1. .I '$D(PSGOEE),+PSJSYSU=3 D EN^PSGPEN(PSGORD)
  1. S PSGOEEF=0 D GETUD^PSJLMGUD(PSGP,PSGORD),ENSFE^PSGOEE0(PSGP,PSGORD),^PSGOE1,EN^VALM("PSJ LM UD ACTION")
  1. ;RTC 178746 - store allergy if not verify the newly created order.
  1. I ($G(PSGORD)["P"),($P($G(^PS(53.1,+PSGORD,0)),U,9)="N"),($G(PSJOCFG)="NEW UD") D SETOC^PSJNEWOC(PSGORD)
  1. G AD
  1. Q
  1. OC ;
  1. NEW PSJDD,PSJALLGY,PSJALGY1
  1. K PSGORQF
  1. ;; START NCC REMEDIATION >> 327*RJS
  1. N CLOZFLG S CLOZFLG=$$ISCLOZ^PSJCLOZ(,PSGPD) I CLOZFLG D Q:$G(ANQX)
  1. .S DIR(0)="N^12.5:3000:1",DIR("A")="CLOZAPINE dosage (mg/day) ? " D ^DIR K DIR I $D(DIRUT) S (CHK,ANQX)=1 Q
  1. .S (PSGNTDD,PSODAND)=X,PSGDN=$P(CLOZFLG,U,2)
  1. ;; END NCC REMEDIATION >> 327*RJS
  1. D FULL^VALM1
  1. S PSJDD=+$$DD53P45^PSJMISC() I 'PSJDD S PSGORQF=1 Q
  1. I +$G(PSGEDTOI) D
  1. . S PSJALGY1=1
  1. . D ENDDC^PSGSICHK($G(PSGP),PSJDD)
  1. D:'$G(PSGORQF) IN^PSJOCDS($G(PSGORD),"UD",PSJDD)
  1. Q
  1. EDIT(PROMPT) ;
  1. ; Edit fields in a UD order.
  1. ; PROMPT=0 - Select fields to edit by number.
  1. ; PROMPT=1 - Prompt to select fields for editing.
  1. ;
  1. ;* D @$S('PROMPT:"ENEFA2^PSGON",1:"ENEFA^PSGON") Q:'Y S PSGOEEG=3 D EDIT^PSGOEE ;$S(PSGOEEWF[53.1:3,1:5) D:Y EDIT^PSGOEE
  1. ; PSJ*5.0*448: CORRECTLY SETTING PSGOEEWF
  1. D @$S('PROMPT:"ENEFA2^PSGON",1:"ENEFA^PSGON") Q:'Y S:$G(PSJNEWOE) PSGOEEWF="^PS(53.1,"_+$G(PSGORD)_"," S PSGOEEG=$S('$D(PSGOEEWF):3,PSGOEEWF[53.1:3,1:5) D EDIT^PSGOEE
  1. I $G(PSJNEWOE) S PSGOEENO=0,DR="",VALMBCK="R"
  1. I '$G(PSJNEWOE) D ENNOU^PSGOEE0 I 'PSGOEENO,DR="" S VALMBCK="R" Q
  1. I 'PSGOEENO,$D(PSGOES) D ENNOU^PSGOEE0 ; only update on order sets
  1. ;*179 No longer call CKDT^PSGOEE from here.
  1. ;I 'PSGOEENO,$G(PSGPDNX)=1 D CKDT^PSGOEE
  1. I $G(PSGOEER)["101^PSGOE8" S PSGEDTOI=1
  1. K VALMSG I PSGOEENO D
  1. .S VALMSG="This change will cause a new order to be created." D GTSTATUS^PSGOEE,CHKDD^PSGOEE,CKDT^PSGOEE ;*373
  1. .S PSGEBN=$$ENNPN^PSGMI(DUZ),PSGLIN=$$ENDD^PSGMI(PSGDT)_U_$$ENDTC^PSGMI(PSGDT),PSGLI=PSGDT
  1. D CHK^PSGOEV("^^"_PSGMR_"^^^^"_PSGST,PSGPDRG_U_PSGDO,PSGSCH_U_PSGSD_"^^"_PSGFD)
  1. D INIT^PSJLMUDE(PSGP,$G(PSGORD))
  1. Q
  1. DONE ;
  1. K %,DA,DIC,DIE,DR,DRG,DRGN,DRGO,ND,OC,ORIFN,ORIT,ORPK,ORSTOP,ORSTRT,ORSTS,ORTX,PC,PSGDO,PSGMR,PSGMRN,PSGNEDFD,PSGNEFD,PSGNESD,PSGOES,PSGOROE1,PSGORD,PSGS0XT,PSGS0Y,PSGSCH,PSGSI,PSGX,Y,Z
  1. K PSGEDTOI,PSJOCFG,PSGDUR,PSGRMVT,PSGRMV,PSGRF,ND2,ND2P1 ;*315
  1. Q
  1. ;
  1. GDO ;
  1. W !!,"Drug is not found in Formulary List." F S %=1 W !,"Would you like to try to search the list again" D YN^DICN Q:% D TAM
  1. Q:%<2
  1. FTD ;
  1. R !!,"Enter FREE TEXT DRUG: ",PSGDRGN:DTIME E W $C(7) S PSGDRGN="^" Q
  1. Q:"^"[PSGDRGN S X=$S(PSGDRGN'?.ANP:"Control character(s)",PSGDRGN["^":"Up-arrow ('^') in text",$L(PSGDRGN)>39:"Response longer than 39 characters",1:"") I X]"" W $C(7)," ??",!?2,"(",X," not allowed.)" G FTD
  1. Q:PSGDRGN'?1."?"
  1. W !!?2,"ENTER DRUG ORDERED (1-39 CHARACTERS).",!?2,"Since the drug cannot be found in the DRUG file, enter the drug name here",!,"exactly as ordered. Press the RETURN key (or enter an '^') to skip over this",!,"drug, or to again search the"
  1. W " DRUG file for this one." G FTD
  1. ;
  1. TAM ; Try Again Message
  1. W !!," Enter a 'Y' to try again to find the drug ordered from the Formulary. (The",!,"order cannot become active until a Formulary drug has been entered.) Enter 'N'",!,"to enter the drug ordered as free text for later reference."
  1. W " Enter '^' to exit.",! Q
  1. ACTLOC(LOC) ; Function: returns TRUE if active hospital location; p319
  1. ; IA# 10040.
  1. N D0,X I +$G(^SC(LOC,"OOS")) Q 0 ; screen out OOS entry
  1. S D0=+$G(^SC(LOC,42)) I D0 D WIN^DGPMDDCF Q 'X ; chk out of svc wards
  1. S X=$G(^SC(LOC,"I")) I +X=0 Q 1 ; no inactivate date
  1. I DT>$P(X,U)&($P(X,U,2)=""!(DT<$P(X,U,2))) Q 0 ; chk reactivate date
  1. Q 1 ; must still be active
  1. ;
  1. IMOLOC(LOC,PSGP) ; Is it an IMO location; p319
  1. N PSJY
  1. I $G(LOC)=""!('+$G(PSGP)) Q -1
  1. S PSJY=$$SDIMO^SDAMA203(LOC,PSGP)
  1. I PSJY=-3 D
  1. .I $P($G(^SC(LOC,0)),U,3)'="C" Q
  1. .I $D(^SC("AE",1,LOC))=1 S PSJY=1
  1. .K SDIMO(1)
  1. Q PSJY