PSIVORE2 ;BIR/RGY,PR,MLM - ACT, NEW ORDER (CONT. OF PSIVORE1) ;Nov 10, 2020@14:01:05
;;5.0;INPATIENT MEDICATIONS;**21,58,101,244,290,329,319,399,430**;16 DEC 97;Build 1
;
; References to ^PS(55 supported by DBIA #2191.
;
DEQ ;
S P(4)=$P(^PS(55,DFN,"IV",+ON,0),U,4),ACTION=1,TRACK=4 D ^PSIVLTR D ^PSIVHYPL:P(4)="H",^PSIVLABL:P(4)'="H"
K ;
S:$D(ZTQUEUED) ZTREQ="@" K PSIVMI,PSI,OD,PSIVEC,PSIVSC,I,PSIVNOL,PSIV1,PSIVA,PSIVDOSE,PSGCNT,PSGSA,PSCT,PDOSE,PDATE,PSIVLABN,UP1,PLAST Q
TL ;
W ! F X=3:3:24 W " ",$S($L(X)=1:" ",1:""),X
W ! F X=1:1:24 W "..:"
K PSI F X=0:0 S X=$O(^PS(59.5,PSIVSN,2,"AC",P(4),X)) Q:'X S PSI(+("."_$P(^PS(59.5,PSIVSN,2,X,0),U)))=$S($P($P(^(0),U,6),".")=DT:"*",1:"")
S PSI=P(4) D TL1
K PSI S:'$D(PSGSA) PSGSA="" F PSI=1:1 S X=$P(PSGSA," ",PSI) Q:X="" I X S PSI(X#1)=""
S PSI="^" D TL1
D NOW^%DTC S Y=% S PSI(Y#1)="",PSI="N" D TL1 Q
TL1 ;
W ! S Y="" F X=0:0 S Y=$O(PSI(Y)) Q:'Y W ?3*$E(Y_"000",2,3)-1+$S($E(Y_"000",4,5)>40:2,$E(Y_"000",4,5)>20:1,1:0),PSI,PSI(Y)
K PSI Q
C ;
S SNM=0 F DAT=0:0 S DAT=$O(^PS(55,"PSIVSUS",PSIVSN,DFN,+ON,DAT)) Q:'DAT S SNM=SNM+$P(^(DAT),U)
Q
;
CONVER(X,Y) ;
;***$$FMADD^XLFDT(DT.HH,D,H,M,S) returns the DT.HH+(D,H,M,S)
;*I +P(15)>1440 S X=$$FMADD^XLFDT($P(PSGSA," "),"","",(P(15)*(Y-1))) Q X
I +P(15)>1440 S X=$$CONVER1($P(PSGSA," "),P(15),(Y-1)) Q X
S PDOSE=X S:Y=2 PDATE=$E($P(PSGSA," "),1,7)
I $P(PSGSA," ",Y-1)#1'<PDOSE!(P(15)>1440) S X1=PDATE,X2=1 D C^%DTC S PDATE=X,X=X_PDOSE Q X
S X=PDATE_PDOSE
Q X
;
CONVER1(ORDDT,X,Y) ;
;* This sub-routine is necessary when a schedule such as q36h was
;* entered and the Start date is such as T-3@1200. Without these codes
;* instead of schedule due for T@2400 it will display as T+1@0000.
NEW DAYS,MINS S (DAYS,MINS)=0
S DAYS=(X*Y)\1440,MINS=(X*Y)#1440
S X=$$FMADD^XLFDT(ORDDT,DAYS,"",MINS)
Q X
;
INCOMP ; Delete order missing critical information.
N DIR,PSIVAC W !!,$C(7),"THIS ORDER IS NOT USABLE!",!,"Enter ""D"" to Delete, or ""B"" to Bypass",!
S DIR(0)="SOA^D:DELETE;B:BYPASS",DIR("A")="ACTION (B/D): ",DIR("??")="^S HELP=""INCOMP"" D ^PSIVHLP2" D ^DIR K DIR Q:Y="B"!$D(DIRUT) S PSIVAC="N"
;
DEL55 ; Delete order from 55.
I ON55'["V"!($G(P(21))]"") Q
;p430 nothing to delete, quit out
I $D(^PS(55,DFN,"IV",+ON55,0))=0 Q
I $G(^PS(55,DFN,"IV",+ON55,0))=+ON55 NEW PSIVORFA S PSIVORFA=1 ; P290 If only operating on a stub, do not display status message below
S DIK="^PS(55,"_DFN_",""IV"",",DA(1)=DFN,DA=+ON55 D ^DIK W:'$G(PSIVORFA) $C(7),"...Order ",$S($E($G(PSIVAC),2)="N":"deleted.",1:"unchanged.")
N DA,DIK,ORIFN S ORIFN=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,21) I ORIFN,$E($G(PSIVAC),2)="N" D EN1^PSJHL2(DFN,"OD",+ON55_"V","ORDER DELETED")
L -^PS(55,DFN,"IV",+ON55)
Q
;
NEW ; New order entry
N ON D NEWENT^PSIVORFE S DRGN="",P("IVRM")=+PSIVSN_U_$P($G(^PS(59.5,+PSIVSN,0)),U) ;*PSJ*5*244 - NEW ON
K DRG,PSGFDX F X="AD","DRG","LF","LFA","CUM","MR","SOL","OPI","OT","SYRS","REM","SI","IND",2,3,4,5,7,8,9,11,12,15,17,23 S:'$D(P(X)) P(X)="" ;*399-IND
S P(17)="A",P(4)=$E($G(PSIVTYPE)) S:"CS"[P(4) P(23)=$P($G(PSIVTYPE),U,2)
D:P(4)="" 53^PSIVORC1 Q:$G(P(4))="" S Y=$P($G(^PS(55,DFN,5.1)),U,2),P(6)=Y_U_$P($G(^VA(200,+Y,0)),U)
I $G(PSJCLAPP) S P("CLIN")=$P(PSJCLAPP,U),P("APPT")=$P(PSJCLAPP,U,2) ;*p319
D OTYP^PSIVORC1 S PSIVOK="",EDIT="57^58^59^3"_$S(P("DTYP")=1:"^26^39",1:"")_"^63^64^132^10^25^1" ;*399-IND-132
D EDIT^PSIVEDT Q:'$G(P(2)) D GTOT^PSIVUTL(P(4)) D:$G(P("PD"))="" GTPD
Q
;
GTPD ; Find Orderable Item/dosage ordered for IM.
S P("PD")="" F DRGT="AD","SOL" Q:P("PD") F DRGI=0:0 S DRGI=$O(DRG(DRGT,DRGI)) Q:'DRGI D
. S X=DRG(DRGT,DRGI) S:$P(X,U,6) P("PD")=$P(X,U,6)_U_$$OIDF^PSJLMUT1(+$P(X,U,6))
. S P("DO")=$P(X,U,3)
. ;S:$G(P("DO"))="" P("DO")=$P(X,U,3)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVORE2 3807 printed Dec 13, 2024@02:04:40 Page 2
PSIVORE2 ;BIR/RGY,PR,MLM - ACT, NEW ORDER (CONT. OF PSIVORE1) ;Nov 10, 2020@14:01:05
+1 ;;5.0;INPATIENT MEDICATIONS;**21,58,101,244,290,329,319,399,430**;16 DEC 97;Build 1
+2 ;
+3 ; References to ^PS(55 supported by DBIA #2191.
+4 ;
DEQ ;
+1 SET P(4)=$PIECE(^PS(55,DFN,"IV",+ON,0),U,4)
SET ACTION=1
SET TRACK=4
DO ^PSIVLTR
if P(4)="H"
DO ^PSIVHYPL
if P(4)'="H"
DO ^PSIVLABL
K ;
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL PSIVMI,PSI,OD,PSIVEC,PSIVSC,I,PSIVNOL,PSIV1,PSIVA,PSIVDOSE,PSGCNT,PSGSA,PSCT,PDOSE,PDATE,PSIVLABN,UP1,PLAST
QUIT
TL ;
+1 WRITE !
FOR X=3:3:24
WRITE " ",$SELECT($LENGTH(X)=1:" ",1:""),X
+2 WRITE !
FOR X=1:1:24
WRITE "..:"
+3 KILL PSI
FOR X=0:0
SET X=$ORDER(^PS(59.5,PSIVSN,2,"AC",P(4),X))
if 'X
QUIT
SET PSI(+("."_$PIECE(^PS(59.5,PSIVSN,2,X,0),U)))=$SELECT($PIECE($PIECE(^(0),U,6),".")=DT:"*",1:"")
+4 SET PSI=P(4)
DO TL1
+5 KILL PSI
if '$DATA(PSGSA)
SET PSGSA=""
FOR PSI=1:1
SET X=$PIECE(PSGSA," ",PSI)
if X=""
QUIT
IF X
SET PSI(X#1)=""
+6 SET PSI="^"
DO TL1
+7 DO NOW^%DTC
SET Y=%
SET PSI(Y#1)=""
SET PSI="N"
DO TL1
QUIT
TL1 ;
+1 WRITE !
SET Y=""
FOR X=0:0
SET Y=$ORDER(PSI(Y))
if 'Y
QUIT
WRITE ?3*$EXTRACT(Y_"000",2,3)-1+$SELECT($EXTRACT(Y_"000",4,5)>40:2,$EXTRACT(Y_"000",4,5)>20:1,1:0),PSI,PSI(Y)
+2 KILL PSI
QUIT
C ;
+1 SET SNM=0
FOR DAT=0:0
SET DAT=$ORDER(^PS(55,"PSIVSUS",PSIVSN,DFN,+ON,DAT))
if 'DAT
QUIT
SET SNM=SNM+$PIECE(^(DAT),U)
+2 QUIT
+3 ;
CONVER(X,Y) ;
+1 ;***$$FMADD^XLFDT(DT.HH,D,H,M,S) returns the DT.HH+(D,H,M,S)
+2 ;*I +P(15)>1440 S X=$$FMADD^XLFDT($P(PSGSA," "),"","",(P(15)*(Y-1))) Q X
+3 IF +P(15)>1440
SET X=$$CONVER1($PIECE(PSGSA," "),P(15),(Y-1))
QUIT X
+4 SET PDOSE=X
if Y=2
SET PDATE=$EXTRACT($PIECE(PSGSA," "),1,7)
+5 IF $PIECE(PSGSA," ",Y-1)#1'<PDOSE!(P(15)>1440)
SET X1=PDATE
SET X2=1
DO C^%DTC
SET PDATE=X
SET X=X_PDOSE
QUIT X
+6 SET X=PDATE_PDOSE
+7 QUIT X
+8 ;
CONVER1(ORDDT,X,Y) ;
+1 ;* This sub-routine is necessary when a schedule such as q36h was
+2 ;* entered and the Start date is such as T-3@1200. Without these codes
+3 ;* instead of schedule due for T@2400 it will display as T+1@0000.
+4 NEW DAYS,MINS
SET (DAYS,MINS)=0
+5 SET DAYS=(X*Y)\1440
SET MINS=(X*Y)#1440
+6 SET X=$$FMADD^XLFDT(ORDDT,DAYS,"",MINS)
+7 QUIT X
+8 ;
INCOMP ; Delete order missing critical information.
+1 NEW DIR,PSIVAC
WRITE !!,$CHAR(7),"THIS ORDER IS NOT USABLE!",!,"Enter ""D"" to Delete, or ""B"" to Bypass",!
+2 SET DIR(0)="SOA^D:DELETE;B:BYPASS"
SET DIR("A")="ACTION (B/D): "
SET DIR("??")="^S HELP=""INCOMP"" D ^PSIVHLP2"
DO ^DIR
KILL DIR
if Y="B"!$DATA(DIRUT)
QUIT
SET PSIVAC="N"
+3 ;
DEL55 ; Delete order from 55.
+1 IF ON55'["V"!($GET(P(21))]"")
QUIT
+2 ;p430 nothing to delete, quit out
+3 IF $DATA(^PS(55,DFN,"IV",+ON55,0))=0
QUIT
+4 ; P290 If only operating on a stub, do not display status message below
IF $GET(^PS(55,DFN,"IV",+ON55,0))=+ON55
NEW PSIVORFA
SET PSIVORFA=1
+5 SET DIK="^PS(55,"_DFN_",""IV"","
SET DA(1)=DFN
SET DA=+ON55
DO ^DIK
if '$GET(PSIVORFA)
WRITE $CHAR(7),"...Order ",$SELECT($EXTRACT($GET(PSIVAC),2)="N":"deleted.",1:"unchanged.")
+6 NEW DA,DIK,ORIFN
SET ORIFN=$PIECE($GET(^PS(55,DFN,"IV",+ON55,0)),U,21)
IF ORIFN
IF $EXTRACT($GET(PSIVAC),2)="N"
DO EN1^PSJHL2(DFN,"OD",+ON55_"V","ORDER DELETED")
+7 LOCK -^PS(55,DFN,"IV",+ON55)
+8 QUIT
+9 ;
NEW ; New order entry
+1 ;*PSJ*5*244 - NEW ON
NEW ON
DO NEWENT^PSIVORFE
SET DRGN=""
SET P("IVRM")=+PSIVSN_U_$PIECE($GET(^PS(59.5,+PSIVSN,0)),U)
+2 ;*399-IND
KILL DRG,PSGFDX
FOR X="AD","DRG","LF","LFA","CUM","MR","SOL","OPI","OT","SYRS","REM","SI","IND",2,3,4,5,7,8,9,11,12,15,17,23
if '$DATA(P(X))
SET P(X)=""
+3 SET P(17)="A"
SET P(4)=$EXTRACT($GET(PSIVTYPE))
if "CS"[P(4)
SET P(23)=$PIECE($GET(PSIVTYPE),U,2)
+4 if P(4)=""
DO 53^PSIVORC1
if $GET(P(4))=""
QUIT
SET Y=$PIECE($GET(^PS(55,DFN,5.1)),U,2)
SET P(6)=Y_U_$PIECE($GET(^VA(200,+Y,0)),U)
+5 ;*p319
IF $GET(PSJCLAPP)
SET P("CLIN")=$PIECE(PSJCLAPP,U)
SET P("APPT")=$PIECE(PSJCLAPP,U,2)
+6 ;*399-IND-132
DO OTYP^PSIVORC1
SET PSIVOK=""
SET EDIT="57^58^59^3"_$SELECT(P("DTYP")=1:"^26^39",1:"")_"^63^64^132^10^25^1"
+7 DO EDIT^PSIVEDT
if '$GET(P(2))
QUIT
DO GTOT^PSIVUTL(P(4))
if $GET(P("PD"))=""
DO GTPD
+8 QUIT
+9 ;
GTPD ; Find Orderable Item/dosage ordered for IM.
+1 SET P("PD")=""
FOR DRGT="AD","SOL"
if P("PD")
QUIT
FOR DRGI=0:0
SET DRGI=$ORDER(DRG(DRGT,DRGI))
if 'DRGI
QUIT
Begin DoDot:1
+2 SET X=DRG(DRGT,DRGI)
if $PIECE(X,U,6)
SET P("PD")=$PIECE(X,U,6)_U_$$OIDF^PSJLMUT1(+$PIECE(X,U,6))
+3 SET P("DO")=$PIECE(X,U,3)
+4 ;S:$G(P("DO"))="" P("DO")=$P(X,U,3)
End DoDot:1
+5 QUIT
