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

PSONEW.m

Go to the documentation of this file.
PSONEW ;BIR/SAB - new rx order main driver ;Jul 24, 2017@15:24
 ;;7.0;OUTPATIENT PHARMACY;**11,27,32,46,94,130,268,225,251,379,390,417,313,411,457,524**;DEC 1997;Build 28
 ;External reference to UL^PSSLOCK supported by DBIA 2789
 ;External reference to $$L^PSSLOCK supported by DBIA 2789
 ;External reference to ^VA(200 supported by DBIA 224
 ;External reference to ^XUSEC( supported by DBIA 10076
 ;External reference to ^ORX1 supported by DBIA 2186
 ;External reference to ^ORX2 supported by DBIA 867
 ;External reference to ^TIUEDIT supported by DBIA 2410
 ;External reference to ^DD("DILOCKTM" supported by DBIA 999
 ;---------------------------------------------------------------
OERR ;backdoor new rx for v7
 K PSOREEDT,COPY,SPEED,PSOEDIT,DUR,DRET,PSOTITRX,PSOMTFLG N PSOCKCON,PSODAOC
 S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK S VALMBCK="" Q
 K PSOPLCK S X=PSODFN_";DPT(" D LK^ORX2 I 'Y S VALMSG="Another person is entering orders for this patient.",VALMBCK="" D UL^PSSLOCK(PSODFN) Q
AGAIN N VALMCNT K PSODRUG,PSOCOU,PSOCOUU,PSONOOR,PSORX("FN"),PSORX("DFLG"),PSOQUIT,POERR S PSORX("DFLG")=0
 N PSOHZ,PSOLSTDR S (PSOHZ,PSOLSTDR)=0       ;*524
 W ! D HLDHDR^PSOLMUTL S (PSONEW("QFLG"),PSONEW("DFLG"),PSOQUIT)=0,PSOFROM="NEW",PSONOEDT=1
 K ORD D FULL^VALM1,^PSONEW1 ; Continue order entry
 I PSONEW("QFLG") G END
 I PSONEW("DFLG") W !,$C(7),"RX DELETED",! S:$G(POERR) POERR("DFLG")=1,VALMBCK="Q" G END
 D:$P($G(PSOPAR),"^",7)=1 AUTO^PSONRXN I $P($G(PSOPAR),"^",7)'=1 S PSOX=PSONEW("RX #") D CHECK^PSONRXN
 I PSONEW("DFLG")!PSONEW("QFLG") D DEL S:$G(POERR) POERR("DFLG")=1,VALMBCK="R" G END
 D NOOR I PSONEW("DFLG") D DEL G END
 D ^PSONEW2 I PSONEW("DFLG") D DEL S:$G(POERR) POERR("DFLG")=1,VALMBCK="R" G END ; Asks if correct
 G:$G(PSORX("FN")) END
 D EN^PSON52(.PSONEW) ; Files entry in File 52
 D NPSOSD^PSOUTIL(.PSONEW) ; Adds newly added rx to PSOSD array
 S VALMBCK="R"
 ;
 ; - Possible Titration prescription
 I $G(PSONEW("IRXN")) D MARK^PSOOTMRX(PSONEW("IRXN"),0)
 ;
END D EOJ ; Clean up          
 I '$G(PSORX("FN")) W ! K DIR,DIRUT,DUOUT,DTOUT S DIR(0)="Y",DIR("B")="YES",DIR("A")="Another New Order for "_PSORX("NAME") D ^DIR K DIR,DIRUT,DUOUT,DTOUT I Y K PSONEW,PSDRUG,ORD G AGAIN
 D ^PSOBUILD,BLD^PSOORUT1 S X=PSODFN_";DPT(" D ULK^ORX2 D UL^PSSLOCK(PSODFN)
 D RV^PSOORFL
 S VALMBCK="R" K PSORX("FN") Q
 ;----------------------------------------------------------------
DEL ;
 W !,$C(7),"RX DELETED",!
 I $P($G(PSOPAR),"^",7)=1 D
 . S DIE="^PS(59,",DA=PSOSITE,PSOY=$O(PSONEW("OLD LAST RX#",""))
 . S PSOX=PSONEW("OLD LAST RX#",PSOY)
 . L +^PS(59,+PSOSITE,PSOY):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
 . S DR=$S(PSOY=8:"2003////"_PSOX,PSOY=3:"1002.1////"_PSOX,1:"2003////"_PSOX)
 . D:PSOX<$$GET1^DIQ(59,+PSOSITE,+DR,"I") ^DIE K DIE,X,Y
 . L -^PS(59,+PSOSITE,PSOY)
 . K PSOX,PSOY Q
EOJ ;
 I $D(PSONEW("RX #")) L -^PSRX("B",PSONEW("RX #")) ; +Lock set in PSONRXN
 K PSONOEDT,PSONEW,PSODRUG,ANQDATA,LSI,C,MAX,MIN,NDF,REF,SIG,SER,PSOFLAG,PSOHI,PSOLO,PSONOOR,PSOCOUU,PSOCOU,PSORX("EDIT"),ZNEW
 D CLEAN^PSOVER1
 K ^TMP("PSORXDC",$J),RORD,ACOM,ACNT,CRIT,DEF,F1,GG,I1,IEN,INDT,LAST,MSG,NIEN,STA,DUR,DRET,PSOPRC
 S (ZRXN,RXN)=$O(^TMP("PSORXN",$J,0)) I RXN D
 .S RXN1=^TMP("PSORXN",$J,RXN) D EN^PSOHLSN1(RXN,$P(RXN1,"^"),$P(RXN1,"^",2),"",$P(RXN1,"^",3))
 .I $$GET1^DIQ(52,RXN,100,"I")=5 D EN^PSOHLSN1(RXN,"SC","ZS","")
 .;; START NCC REMEDIATION >> 457*MZR
 .N PSOCLOZO S PSOCLOZO=($$GET1^DIQ(50,+$$GET1^DIQ(52,RXN,6,"I"),17.5)="PSOCLO1")  ; Clozapine order
 .I PSOCLOZO,$G(PSOLOGDT) N ORN S ORN=$$GET1^DIQ(52,RXN,39.3,"I") I ORN D  ;/MZR populate ^XTMP entry with order #
 ..I $P($G(^XTMP("YSCLTRN",DT,DFN,PSOLOGDT,0)),"^",3)=RXN D ORDSET^YSCLTST6(ORN)
 .;; END NCC REMEDIATION >> 457*457
 .;saves drug allergy order chks pso*7*390
 .I $D(^TMP("PSODAOC",$J)) D
 ..S RXN=ZRXN,PSODAOC="Rx Backdoor "_$S($$GET1^DIQ(52,RXN,100,"I")=4:"NON-VERIFIED ",1:"")_"NEW Order Acceptance_OP",ZNEW=1
 .D DAOC
 K ZRXN,RXN,RXN1,^TMP("PSORXN",$J),^TMP("PSODAOC",$J),RET,PSODAOC,ZNEW
 I $G(PSONOTE) D FULL^VALM1,MAIN^TIUEDIT(3,.TIUDA,PSODFN,"","","","",1)
 K PSONOTE,PSOCKCON,ZZCOPY
 ;W !! K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to Continue" D ^DIR K DIR,DTOUT,DUOUT
 Q
NOOR ;asks nature of order
 N PSONOODF
 S PSONOODF=0
 ;; START NCC REMEDIATION >> 457*MZR
 ;/MZR Added a next line because otherwise data gets lost
 I $$GET1^DIQ(50,+$G(PSODRUG("IEN")),17.5)="PSOCLO1",'$D(PSONEW("SAND")),$G(PSOSAND) S PSONEW("SAND")=PSOSAND K PSOSAND
 ;; EMD NCC REMEDIATION >> 457*MZR
 I $G(OR0) D  G NOORX ;front door
 .S PSOI=$S($G(PSOSIGFL):1,$G(PSODRUG("OI"))'=$P(OR0,"^",8):1,1:0)
 .I 'PSOI S PSONOOR="" D:$$FIND1^DIC(200.051,","_DUZ_",","X","PSORPH") COUN Q  ;NoO $P(OR0,"^",7)
 .S PSONOODF=1
 .D DIR I $D(DIRUT) S PSONEW("DFLG")=1 Q
 .S PSONOOR=Y D:$$FIND1^DIC(200.051,","_DUZ_",","X","PSORPH") COUN K DIR,DTOUT,DTOUT,DIRUT
 ;backdoor order
 D DIR I $D(DIRUT) S PSONEW("DFLG")=1,VALMBCK="Q" Q
 S PSONOOR=Y K DIK,DA,DIE,DR,PSOI,DIR,DUOUT,DTOUT,DIRUT
 G:'$D(^XUSEC("PSORPH",DUZ)) NOORX
COUN ;patient counseling
 G:$G(PSORX("EDIT"))&('$G(PSOSIGFL)) NOORX K DIR,DUOUT,DTOUT,DIRUT
 S DIR("B")="NO",DIR(0)="52,41" D ^DIR S PSOCOU=$S(Y:Y,1:0)
 I $D(DIRUT)!('PSOCOU) S PSOCOUU=0 D:'$G(SPEED) PRONTE Q
 K:'$G(PSOCOU) PSOCOUU K DIR,DUOUT,DTOUT,DIRUT I Y S DIR(0)="52,42",DIR("B")="NO" D ^DIR S PSOCOUU=$S(Y:Y,1:0)
PRONTE K PSONOTE,DIR,DIRUT,DUOUT
 I $T(MAIN^TIUEDIT)]"",'$G(SPEED) D  K DIR,DIRUT,DUOUT
 .S DIR(0)="Y",DIR("B")="No",DIR("A")="Do you want to enter a Progress Note",DIR("A",1)="" D ^DIR K DIR
 .S PSONOTE=+Y Q  ;I 'Y!($D(DIRUT)) Q
NOORX K X,Y,DIR,DUOUT,DTOUT,DIRUT
 Q
DIR ;ask nature of order
 K DIR,DTOUT,DTOUT,DIRUT I $T(NA^ORX1)]""  D  Q
 .S PSONOOR=$$NA^ORX1($S($G(PSONOODF)!($G(PSONOBCK)):"S",1:"W"),0,"B","Nature of Order",0,"WPSDIVR"_$S($$GET1^DIQ(200,DUZ,53.3):"E",1:""))
 .I +PSONOOR S (Y,PSONOOR)=$P(PSONOOR,"^",3) Q
 .S DIRUT=1 K PSONOOR
 I $D(PSONOOR) S DF=PSONOOR,PSONODF=$S(DF="E":"PROVIDER ENTERED",DF="V":"VERBAL",DF="P":"TELEPHONE",DF="D":"DUPLICATE",DF="S":"SERVICE CORRECTED",DF="I":"POLICY",DF="R":"SERVICE REJECTED",1:"WRITTEN")
 K DIR,DTOUT,DTOUT,DIRUT S DIR("A")="Nature of Order: ",DIR("B")=$S($D(PSONOOR):PSONODF,1:"WRITTEN")
 S DIR(0)="SA^W:WRITTEN;V:VERBAL;P:TELEPHONE;S:SERVICE CORRECTED;D:DUPLICATE;I:POLICY;R:SERVICE REJECTED"_$S($$GET1^DIQ(200,DUZ,53.3):";E:PROVIDER ENTERED",1:"")
 D ^DIR K DF,PSONODF Q:$D(DIRUT)  S PSONOOR=Y
DIRX Q
 ;
NOORE(PSONEW) ;entry point for renew
 D NOOR I $D(DIRUT) S PSONEW("DFLG")=1 Q
 S PSONEW("NOO")=PSONOOR
 Q
DAOC ;adds all backdoor order checks to file 100.05.
 D ^PSONEWOC K ^TMP("PSODAOC",$J),PSRDI
 Q