PSJHL7 ;BIR/LDT-ACTIONS ON HL7 MESSAGES FROM OE/RR (CONT) ;29 AUG 96 / 11:18 AM
;;5.0;INPATIENT MEDICATIONS;**42,47,50,70,82,110,127,133,275,279,315,427**;16 DEC 97;Build 2
;;Per VHA Directive 2004-038, this routine should not be modified.
; Reference to ^PS(50.7 is supported by DBIA# 2180.
; Reference to ^PS(51.1 is supported by DBIA# 2177.
; Reference to ^PS(51.2 is supported by DBIA# 2178.
; Reference to ^PS(52.6 is supported by DBIA# 1231.
; Reference to ^PS(52.7 is supported by DBIA# 2173.
; Reference to ^PS(55 is supported by DBIA# 2191.
; Reference to ^SC( is supported by DBIA# 10040.
; Reference to ^TMP("PSB" is supported by DBIA# 3564.
;
RENEW ;Renew orders from OE/RR
N PSJSYSW0,PSJSYSW,WRDPTR,PSJOSTOP,Q1,Q2,PSGNESD,PSGNEFD
S PSJSYSW0="",PSJSYSW=0 I $G(LOC) S WRDPTR=$G(^SC(+LOC,42)) S:WRDPTR]"" PSJSYSW=+$O(^PS(59.6,"B",WRDPTR,0)) I PSJSYSW S PSJSYSW0=$G(^PS(59.6,PSJSYSW,0))
I PREON["V" D IVSET G DONE
N ND,ND1,ND2,ND2P1,PSGSI,PSGMR,PSGSM,PSGHSM,PSGST,OIDRG,PSGDO,PSGSCH,PSGSOY,PSGOXT,PSGNEDFD,DRUGS,WAT ;*315
S ND=$G(^PS(55,PSJHLDFN,5,+PREON,0)),ND1=$G(^(.2)),ND2=$G(^(2)),ND2P1=$G(^(2.1)),PSGSI=$G(^(6)),PSGWLL=$S($P(PSJSYSW0,"^",4):+$G(^PS(55,PSJHLDFN,5.1)),1:0) ;*315
S PSGNESD=$P(ND2,U,2),PSGNEFD=$P(ND2,U,4) ;P427
I +PSITEM>0,PSITEM'=+$P(ND1,"^") S $P(ND1,"^")=PSITEM
S PSGMR=$P(ND,"^",3),PSGSM=$P(ND,"^",5),PSGHSM=$P(ND,"^",6),PSGST=$P(ND,"^",7),OIDRG=$P(ND1,"^"),PSGDO=$P(ND1,"^",2),DOSE=$P(ND1,"^",5),UNIT=$P(ND1,"^",6),PSGSCH=$P(ND2,"^")
S PSGSOY=$P(ND2,"^",5),PSGOXT=$P(ND2,"^",6),PSGNEDFD=$P($$GTNEDFD^PSGOE7("UI",OIDRG),"^")
S:$P(LOC,"^")'=$P(ND2,"^",10) PSGSOY=$$ENRNAT^PSJHL7($P(ND2,"^",10),+LOC,PSGSCH,PSGSOY)
S X=$O(^PS(55,PSJHLDFN,5,+PREON,1,0)) I X S (Q,Q1)=0 F S Q=$O(^PS(55,PSJHLDFN,5,+PREON,1,Q)) Q:'Q S ND=$G(^(Q,0)) I ND,$S('$P(ND,"^",3):1,1:$P(ND,"^",3)>DT) S Q1=Q1+1,DRUGS(Q1)=$P(ND,"^",1,3)
;S (PSGNESD,PSGNEFD)="" ;p427
D ENWALL^PSGNE3(PSGNESD,PSGNEFD,PSJHLDFN)
I PSGOXT="D",'PSGSOY S PSGSOY=+$E(PSGNESD_"00011",9,12)
S ND=NEWORDER_U_PROVIDER_U_PSGMR_U_"U"_U_PSGSM_U_PSGHSM_U_PSGST_"^^P^^^^^"_LOGIN_U_PSJHLDFN_U_LOGIN S:PSGNEDFD $P(ND,U,$P(PSGNEDFD,U)["L"+10)=+PSGNEDFD
S $P(ND,U,21)=$P(ORDER,U),$P(ND,U,24,25)=ROC_U_PREON
F X="PSGNESD","PSGNEFD" S:@X]"" @X=+@X
S ND2=PSGSCH_U_PSGNESD_"^^"_PSGNEFD_U_PSGSOY_U_PSGOXT
S F="^PS(53.1,"_NEWORDER_",",@(F_"0)")=ND,^(.2)=OIDRG_U_PSGDO_U_ORDCON_U_PRIORITY_U_DOSE_U_UNIT_U_U_$G(PRNTON),^(2)=ND2,^(2.1)=ND2P1 S:$G(PSGSI)]"" ^(6)=PSGSI ;*315
I $D(DRUGS) D
.I $D(@(F_"1,0)")) K @(F_"1)")
.; Naked reference below refers to full reference to ^PS(53.1,+NEWORDER in variable F created using indirection.
.I '$D(@(F_"1,0)")) S ^(0)="^53.11P^0^0"
.S JJ=0 F S JJ=$O(DRUGS(JJ)) Q:'JJ I $S('$P(DRUGS(JJ),U,3):1,1:$P(DRUGS(JJ),U,3)>DT) S $P(@(F_"1,0)"),"^",3,4)=JJ_"^"_JJ,@(F_"1,"_JJ_",0)")=$P(DRUGS(JJ),U,1,2),@(F_"1,""B"","_+DRUGS(JJ)_","_JJ_")")=""
S PSJOSTOP=$G(@("^PS(55,"_PSJHLDFN_",5,"_+$G(PREON)_",2)")),PSJOSTOP=$P(PSJOSTOP,"^",4)
D REN531(NEWORDER,$P(ND,"^",14),$S($G(PREON)["U":$P(ND,"^",2),1:$P(ND,"^",6)),PSJOSTOP,PSJHLDFN)
;
DONE ;
N DA,DR,DIE,PSIVACT,PSIVALT,ON55,PSIVREA
S DIE=$S(PREON["V":"^PS(55,"_PSJHLDFN_",""IV"",",1:"^PS(55,"_PSJHLDFN_",5,"),DA=+PREON,DA(1)=PSJHLDFN,DR=$S(PREON["V":"100////R;123////R;114////"_PSJORDER,1:"28////R;107////R;105////"_PSJORDER)
I PREON["A"!(PREON["U") S PSGAL("C")=18000 D ^PSGAL5
I PREON["V" S PSIVACT=1,PSIVALT=2,ON55=PREON,PSIVREA="R"
D ^DIE
I PREON["V" N DFN S DFN=PSJHLDFN D LOG^PSIVORAL
S PSJHLMTN="ORM" D EN1^PSJHL2(PSJHLDFN,"SC",PREON) S PSJHLMTN="ORR",PSOC="NW"
Q
IVSET ;
N DRG,DRGN,P
S P("RES")="R",P("REN")="",Y=$G(^PS(55,PSJHLDFN,"IV",+PREON,0)) F X=1:1:23 S P(X)=$P(Y,U,X)
S P("PON")=PREON,P(21)=$P(ORDER,U),P(6)=PROVIDER_U_$P($G(^VA(200,+PROVIDER,0)),U),(DRG,DRGN)="",P("REM")=$G(^PS(55,PSJHLDFN,"IV",+PREON,1))
S Y=$G(^PS(55,PSJHLDFN,"IV",+PREON,2)),P("LOG")=LOGIN
S P("CLRK")=CLERK_U_$P($G(^VA(200,+CLERK,0)),U),P("RES")=ROC,P("FRES")=$P(Y,U,9),P("SYRS")=$P(Y,U,4),P("OPI")=$G(^PS(55,PSJHLDFN,"IV",+PREON,3))
S ND=$G(^PS(55,PSJHLDFN,"IV",+PREON,.2)),P("PD")=$S($P(ND,U):$P(ND,U)_U_$P($G(^PS(50.7,+ND,0)),U),1:""),P("DO")=$P(ND,U,2)
S P("MR")=$P(ND,U,3),ND=$G(^PS(51.2,+P("MR"),0)),P("MR")=P("MR")_U_$S($P(ND,U,3)]"":$P(ND,U,3),1:$P(ND,U))
D GTDRG
S P("OT")=$S(P(4)="A":"F",P(4)="H":"I",1:"I")
I P("OT")="F" F DRGT="AD","SOL" F DRGI=0:0 S DRGI=$O(DRG(DRGT,DRGI)) Q:'DRGI I '$P(DRG(DRGT,DRGI),U,5) S P("OT")="I"
PUT531 ; Move data in local variables to 53.1
N IVLIM,IVLIMIT S IVLIM=$$GETDUR^PSJLIVMD(PSJHLDFN,+PREON,$E(PREON,$L(PREON)),1) I IVLIM]"",$G(IVLIMIT) S $P(^PS(53.1,+NEWORDER,2.5),U,4)=IVLIM
S ND(0)=+NEWORDER_U_+P(6)_U_$S(+P("MR"):+P("MR"),1:"")_U_P("OT")_U_U_U_"C",$P(ND(0),U,9)="P"
S $P(ND(0),U,14,16)=P("LOG")_U_PSJHLDFN_U_P("LOG"),$P(ND(0),U,21)=P(21),$P(ND(0),U,24,26)=$G(P("RES"))_U_P("PON")
S ND(2)=P(9)_U_U_U_U_P(11)_U_P(15),$P(ND(4),U,7,9)=+P("CLRK")_U_U_P("REN")
S ND(8)=P(4)_U_P(23)_U_P("SYRS")_U_P(5)_U_P(8)_"^^"_P(7),ND(9)=$S($L(P("REM")_P("OPI")):P("REM")_U_P("OPI"),1:"")
S ND(17)="" I $G(P(8))["@",($P($G(P(8)),"@",2)?1.N) S ND(17)=$P(P(8),"@",2)
F X=0,2,4,8,9,17 S ^PS(53.1,+NEWORDER,X)=ND(X)
S:+P("PD") ^PS(53.1,+NEWORDER,.2)=+P("PD")_U_P("DO")
S $P(^PS(53.1,+NEWORDER,.2),"^",3,4)=ORDCON_U_PRIORITY
;I $G(PRNTON) I $$UP^XLFSTR($G(PSGSCH))="NOW" S PRNTON=""
I $G(PRNTON) S $P(^PS(53.1,+NEWORDER,.2),"^",8)=PRNTON
F DRGT="AD","SOL" D:$D(DRG(DRGT)) PTD531
S PSJOSTOP=$G(@("^PS(55,"_PSJHLDFN_",""IV"","_+PREON_",0)")),PSJOSTOP=$P(PSJOSTOP,"^",3) D
.N IVND S IVND=$G(^PS(53.1,+NEWORDER,0)) D REN531(NEWORDER,$P(IVND,"^",14),$P(ND,"^",2),PSJOSTOP,PSJHLDFN)
Q
PTD531 ; Move drug data from local array into 53.1
K ^PS(53.1,+NEWORDER,DRGT) S ^PS(53.1,+NEWORDER,DRGT,0)=$S(DRGT="AD":"^53.157PA^0^0",1:"^53.158PA^0^0")
F X=0:0 S X=$O(DRG(DRGT,X)) Q:'X D
.S X1=$P(DRG(DRGT,X),U),Y=^PS(53.1,+NEWORDER,DRGT,0),$P(Y,U,3)=$P(Y,U,3)+1,DRG=$P(Y,U,3),$P(Y,U,4)=$P(Y,U,4)+1
.S ^PS(53.1,+NEWORDER,DRGT,0)=Y,Y=+X1_U_$P(DRG(DRGT,X),U,3) S:DRGT="AD" $P(Y,U,3)=$P(DRG(DRGT,X),U,4) S ^PS(53.1,+NEWORDER,DRGT,+DRG,0)=Y,^PS(53.1,+NEWORDER,DRGT,"B",+X1,+DRG)=""
I $G(P("RES"))="R",($G(ND(0))]"") D REN531(+NEWORDER,$P(ND(0),"^",14),$P(ND(0),"^",2),$G(P(3)),$G(DFN))
Q
;
ENRNAT(OWD,NWD,SC,OAT) ;Determine admin times for renewal orders.
;OWD=ORIGINAL W,NWD=NEW WD LOCATION, SC=SCHEDULE, OAT=ORDER ADMIN TIMES
N OWAT,SCP,X,Y,OOAT
S OOAT=OAT,SCP=+$O(^PS(51.1,"APPSJ",+SC,0)),WAT=$P($G(^PS(51.1,SCP,1,+$G(OWD),0)),U,2)
F X="WAT","OAT" F Y=1:1 Q:$L(@X)>240!($P(@X,"-",Y)="") S $P(@X,"-",Y)=$P(@X,"-",Y)_$E("0000",1,4-$L($P(@X,"-",Y)))
I OAT'=WAT Q OOAT
S X=$P($G(^PS(51.1,+SCP,1,NWD,0)),U,2) I X Q X
Q OOAT
;
GTDRG ; Get drug info and place in DRG(.
F DRGT="AD","SOL" S FIL=$S(DRGT="AD":52.6,1:52.7) F Y=0:0 S Y=$O(^PS(55,PSJHLDFN,"IV",+PREON,DRGT,Y)) Q:'Y D
.;Naked reference ^(Y,0) below refers to full global reference ^PS(55,PSJHLDFN,"IV",+PREON,DRGT,Y)) above at GTDRG+1
.S DRG=$G(^(Y,0)),ND=$G(^PS(FIL,+DRG,0)),(DRGI,DRG(DRGT,0))=$G(DRG(DRGT,0))+1,DRG(DRGT,+DRGI)=+DRG_U_$P(ND,U)_U_$P(DRG,U,2)_U_$P(DRG,U,3)_U_$P(ND,U,13)_U_$P(ND,U,11)
Q
;
REN531(PSGORD,PSGDT,PSGOEPR,PSGOFD,PSGP) ;
Q:'PSGORD!'PSGDT!'PSGOEPR!'PSGOFD!'PSGP
N DUP,PSGOLDPR I $G(PREON) D Q:$G(DUP)
.S:$D(^PS(53.1,+PSGORD,14,"B",+PSGDT)) DUP=1 Q
S:$G(PREON)["U" PSGOLDPR=$P($G(^PS(55,PSGP,5,+PREON,0)),"^",2)
S:$G(PREON)["V" PSGOLDPR=$P($G(^PS(55,PSGP,"IV",+PREON,0)),"^",6)
K DR,DA,DIC,DIE,DD,DO S DIC="^PS(53.1,"_+PSGORD_",14,",DIC(0)="L",DIC("P")="53.1114DA",ND14=$G(@(DIC_"0)")),DINUM=$P(ND14,"^",3)+1,DA(2)=PSGP,DA(1)=+PSGORD D
. S DIC("DR")=".01////"_$G(PSGDT)_";1////"_$G(DUZ)_";2////"_$S($G(PSGOLDPR):$G(PSGOLDPR),1:$G(PSGOEPR))_";3////"_$G(PSGOFD),X=$G(PSGDT) D FILE^DICN
K DO,DINUM
I $G(PREON)["U",$D(^PS(55,PSGP,5,+PREON,15,1)) D
.N PSJSYSP S PSJSYSP=$J D GETSI^PSJBCMA5(PSGP,PREON) I $D(^PS(53.45,$J,5)) D FILESI^PSJBCMA5(PSGP,$S(PSGORD=+PSGORD:+PSGORD_"P",1:PSGORD))
I $G(PREON)["V",$D(^PS(55,PSGP,"IV",+PREON,10,1)) D
.N PSJSYSP S PSJSYSP=$J D GETOPI^PSJBCMA5(PSGP,PREON) I $D(^PS(53.45,$J,6)) D FILEOPI^PSJBCMA5(PSGP,$S(PSGORD=+PSGORD:+PSGORD_"P",1:PSGORD))
Q
;
CHK(X,Y,Z) ;Check for required fields
; Input: X="^^"_MED ROUTE_"^^^^"_SCH TYPE
; Y=ORDERABLE ITEM_"^"_DOSAGE ORDERED
; Z=SCHEDULE_"^"_START DATE/TIME_"^^"_STOP DATE/TIME
S:'$D(^PS(50.7,+Y,0)) CHK=1
I ND="" S CHK=CHK_23
E S CHK=CHK_$S($P(X,"^",3):"",1:2)_$S($P(X,"^",7)]"":"",1:3)
K PSGDFLG,PSGPFLG S PSGDI=0
S:'$$DDOK^PSJHL10("^TMP(""PSB"","_$J_",700,",+Y) CHK=CHK_7
;
CHKM ;
Q:'CHK
N MSG2
S MSG="THE FOLLOWING "_$S($L(CHK)>1:"ARE",1:"IS")_" EITHER INVALID OR MISSING FROM THIS ORDER:" F X=1:1:7 S:CHK[X MSG2=$P("ORDERABLE ITEM^MED ROUTE^SCHEDULE TYPE^SCHEDULE^START DATE/TIME^STOP DATE/TIME^DISPENSE DRUG","^",X)
S PSREASON=MSG_MSG2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJHL7 8899 printed Apr 09, 2024@21:08:47 Page 2
PSJHL7 ;BIR/LDT-ACTIONS ON HL7 MESSAGES FROM OE/RR (CONT) ;29 AUG 96 / 11:18 AM
+1 ;;5.0;INPATIENT MEDICATIONS;**42,47,50,70,82,110,127,133,275,279,315,427**;16 DEC 97;Build 2
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ; Reference to ^PS(50.7 is supported by DBIA# 2180.
+4 ; Reference to ^PS(51.1 is supported by DBIA# 2177.
+5 ; Reference to ^PS(51.2 is supported by DBIA# 2178.
+6 ; Reference to ^PS(52.6 is supported by DBIA# 1231.
+7 ; Reference to ^PS(52.7 is supported by DBIA# 2173.
+8 ; Reference to ^PS(55 is supported by DBIA# 2191.
+9 ; Reference to ^SC( is supported by DBIA# 10040.
+10 ; Reference to ^TMP("PSB" is supported by DBIA# 3564.
+11 ;
RENEW ;Renew orders from OE/RR
+1 NEW PSJSYSW0,PSJSYSW,WRDPTR,PSJOSTOP,Q1,Q2,PSGNESD,PSGNEFD
+2 SET PSJSYSW0=""
SET PSJSYSW=0
IF $GET(LOC)
SET WRDPTR=$GET(^SC(+LOC,42))
if WRDPTR]""
SET PSJSYSW=+$ORDER(^PS(59.6,"B",WRDPTR,0))
IF PSJSYSW
SET PSJSYSW0=$GET(^PS(59.6,PSJSYSW,0))
+3 IF PREON["V"
DO IVSET
GOTO DONE
+4 ;*315
NEW ND,ND1,ND2,ND2P1,PSGSI,PSGMR,PSGSM,PSGHSM,PSGST,OIDRG,PSGDO,PSGSCH,PSGSOY,PSGOXT,PSGNEDFD,DRUGS,WAT
+5 ;*315
SET ND=$GET(^PS(55,PSJHLDFN,5,+PREON,0))
SET ND1=$GET(^(.2))
SET ND2=$GET(^(2))
SET ND2P1=$GET(^(2.1))
SET PSGSI=$GET(^(6))
SET PSGWLL=$SELECT($PIECE(PSJSYSW0,"^",4):+$GET(^PS(55,PSJHLDFN,5.1)),1:0)
+6 ;P427
SET PSGNESD=$PIECE(ND2,U,2)
SET PSGNEFD=$PIECE(ND2,U,4)
+7 IF +PSITEM>0
IF PSITEM'=+$PIECE(ND1,"^")
SET $PIECE(ND1,"^")=PSITEM
+8 SET PSGMR=$PIECE(ND,"^",3)
SET PSGSM=$PIECE(ND,"^",5)
SET PSGHSM=$PIECE(ND,"^",6)
SET PSGST=$PIECE(ND,"^",7)
SET OIDRG=$PIECE(ND1,"^")
SET PSGDO=$PIECE(ND1,"^",2)
SET DOSE=$PIECE(ND1,"^",5)
SET UNIT=$PIECE(ND1,"^",6)
SET PSGSCH=$PIECE(ND2,"^")
+9 SET PSGSOY=$PIECE(ND2,"^",5)
SET PSGOXT=$PIECE(ND2,"^",6)
SET PSGNEDFD=$PIECE($$GTNEDFD^PSGOE7("UI",OIDRG),"^")
+10 if $PIECE(LOC,"^")'=$PIECE(ND2,"^",10)
SET PSGSOY=$$ENRNAT^PSJHL7($PIECE(ND2,"^",10),+LOC,PSGSCH,PSGSOY)
+11 SET X=$ORDER(^PS(55,PSJHLDFN,5,+PREON,1,0))
IF X
SET (Q,Q1)=0
FOR
SET Q=$ORDER(^PS(55,PSJHLDFN,5,+PREON,1,Q))
if 'Q
QUIT
SET ND=$GET(^(Q,0))
IF ND
IF $SELECT('$PIECE(ND,"^",3):1,1:$PIECE(ND,"^",3)>DT)
SET Q1=Q1+1
SET DRUGS(Q1)=$PIECE(ND,"^",1,3)
+12 ;S (PSGNESD,PSGNEFD)="" ;p427
+13 DO ENWALL^PSGNE3(PSGNESD,PSGNEFD,PSJHLDFN)
+14 IF PSGOXT="D"
IF 'PSGSOY
SET PSGSOY=+$EXTRACT(PSGNESD_"00011",9,12)
+15 SET ND=NEWORDER_U_PROVIDER_U_PSGMR_U_"U"_U_PSGSM_U_PSGHSM_U_PSGST_"^^P^^^^^"_LOGIN_U_PSJHLDFN_U_LOGIN
if PSGNEDFD
SET $PIECE(ND,U,$PIECE(PSGNEDFD,U)["L"+10)=+PSGNEDFD
+16 SET $PIECE(ND,U,21)=$PIECE(ORDER,U)
SET $PIECE(ND,U,24,25)=ROC_U_PREON
+17 FOR X="PSGNESD","PSGNEFD"
if @X]""
SET @X=+@X
+18 SET ND2=PSGSCH_U_PSGNESD_"^^"_PSGNEFD_U_PSGSOY_U_PSGOXT
+19 ;*315
SET F="^PS(53.1,"_NEWORDER_","
SET @(F_"0)")=ND
SET ^(.2)=OIDRG_U_PSGDO_U_ORDCON_U_PRIORITY_U_DOSE_U_UNIT_U_U_$GET(PRNTON)
SET ^(2)=ND2
SET ^(2.1)=ND2P1
if $GET(PSGSI)]""
SET ^(6)=PSGSI
+20 IF $DATA(DRUGS)
Begin DoDot:1
+21 IF $DATA(@(F_"1,0)"))
KILL @(F_"1)")
+22 ; Naked reference below refers to full reference to ^PS(53.1,+NEWORDER in variable F created using indirection.
+23 IF '$DATA(@(F_"1,0)"))
SET ^(0)="^53.11P^0^0"
+24 SET JJ=0
FOR
SET JJ=$ORDER(DRUGS(JJ))
if 'JJ
QUIT
IF $SELECT('$PIECE(DRUGS(JJ),U,3):1,1:$PIECE(DRUGS(JJ),U,3)>DT)
SET $PIECE(@(F_"1,0)"),"^",3,4)=JJ_"^"_JJ
SET @(F_"1,"_JJ_",0)")=$PIECE(DRUGS(JJ),U,1,2)
SET @(F_"1,""B"","_+DRUGS(JJ)_","_JJ_")")=""
End DoDot:1
+25 SET PSJOSTOP=$GET(@("^PS(55,"_PSJHLDFN_",5,"_+$GET(PREON)_",2)"))
SET PSJOSTOP=$PIECE(PSJOSTOP,"^",4)
+26 DO REN531(NEWORDER,$PIECE(ND,"^",14),$SELECT($GET(PREON)["U":$PIECE(ND,"^",2),1:$PIECE(ND,"^",6)),PSJOSTOP,PSJHLDFN)
+27 ;
DONE ;
+1 NEW DA,DR,DIE,PSIVACT,PSIVALT,ON55,PSIVREA
+2 SET DIE=$SELECT(PREON["V":"^PS(55,"_PSJHLDFN_",""IV"",",1:"^PS(55,"_PSJHLDFN_",5,")
SET DA=+PREON
SET DA(1)=PSJHLDFN
SET DR=$SELECT(PREON["V":"100////R;123////R;114////"_PSJORDER,1:"28////R;107////R;105////"_PSJORDER)
+3 IF PREON["A"!(PREON["U")
SET PSGAL("C")=18000
DO ^PSGAL5
+4 IF PREON["V"
SET PSIVACT=1
SET PSIVALT=2
SET ON55=PREON
SET PSIVREA="R"
+5 DO ^DIE
+6 IF PREON["V"
NEW DFN
SET DFN=PSJHLDFN
DO LOG^PSIVORAL
+7 SET PSJHLMTN="ORM"
DO EN1^PSJHL2(PSJHLDFN,"SC",PREON)
SET PSJHLMTN="ORR"
SET PSOC="NW"
+8 QUIT
IVSET ;
+1 NEW DRG,DRGN,P
+2 SET P("RES")="R"
SET P("REN")=""
SET Y=$GET(^PS(55,PSJHLDFN,"IV",+PREON,0))
FOR X=1:1:23
SET P(X)=$PIECE(Y,U,X)
+3 SET P("PON")=PREON
SET P(21)=$PIECE(ORDER,U)
SET P(6)=PROVIDER_U_$PIECE($GET(^VA(200,+PROVIDER,0)),U)
SET (DRG,DRGN)=""
SET P("REM")=$GET(^PS(55,PSJHLDFN,"IV",+PREON,1))
+4 SET Y=$GET(^PS(55,PSJHLDFN,"IV",+PREON,2))
SET P("LOG")=LOGIN
+5 SET P("CLRK")=CLERK_U_$PIECE($GET(^VA(200,+CLERK,0)),U)
SET P("RES")=ROC
SET P("FRES")=$PIECE(Y,U,9)
SET P("SYRS")=$PIECE(Y,U,4)
SET P("OPI")=$GET(^PS(55,PSJHLDFN,"IV",+PREON,3))
+6 SET ND=$GET(^PS(55,PSJHLDFN,"IV",+PREON,.2))
SET P("PD")=$SELECT($PIECE(ND,U):$PIECE(ND,U)_U_$PIECE($GET(^PS(50.7,+ND,0)),U),1:"")
SET P("DO")=$PIECE(ND,U,2)
+7 SET P("MR")=$PIECE(ND,U,3)
SET ND=$GET(^PS(51.2,+P("MR"),0))
SET P("MR")=P("MR")_U_$SELECT($PIECE(ND,U,3)]"":$PIECE(ND,U,3),1:$PIECE(ND,U))
+8 DO GTDRG
+9 SET P("OT")=$SELECT(P(4)="A":"F",P(4)="H":"I",1:"I")
+10 IF P("OT")="F"
FOR DRGT="AD","SOL"
FOR DRGI=0:0
SET DRGI=$ORDER(DRG(DRGT,DRGI))
if 'DRGI
QUIT
IF '$PIECE(DRG(DRGT,DRGI),U,5)
SET P("OT")="I"
PUT531 ; Move data in local variables to 53.1
+1 NEW IVLIM,IVLIMIT
SET IVLIM=$$GETDUR^PSJLIVMD(PSJHLDFN,+PREON,$EXTRACT(PREON,$LENGTH(PREON)),1)
IF IVLIM]""
IF $GET(IVLIMIT)
SET $PIECE(^PS(53.1,+NEWORDER,2.5),U,4)=IVLIM
+2 SET ND(0)=+NEWORDER_U_+P(6)_U_$SELECT(+P("MR"):+P("MR"),1:"")_U_P("OT")_U_U_U_"C"
SET $PIECE(ND(0),U,9)="P"
+3 SET $PIECE(ND(0),U,14,16)=P("LOG")_U_PSJHLDFN_U_P("LOG")
SET $PIECE(ND(0),U,21)=P(21)
SET $PIECE(ND(0),U,24,26)=$GET(P("RES"))_U_P("PON")
+4 SET ND(2)=P(9)_U_U_U_U_P(11)_U_P(15)
SET $PIECE(ND(4),U,7,9)=+P("CLRK")_U_U_P("REN")
+5 SET ND(8)=P(4)_U_P(23)_U_P("SYRS")_U_P(5)_U_P(8)_"^^"_P(7)
SET ND(9)=$SELECT($LENGTH(P("REM")_P("OPI")):P("REM")_U_P("OPI"),1:"")
+6 SET ND(17)=""
IF $GET(P(8))["@"
IF ($PIECE($GET(P(8)),"@",2)?1.N)
SET ND(17)=$PIECE(P(8),"@",2)
+7 FOR X=0,2,4,8,9,17
SET ^PS(53.1,+NEWORDER,X)=ND(X)
+8 if +P("PD")
SET ^PS(53.1,+NEWORDER,.2)=+P("PD")_U_P("DO")
+9 SET $PIECE(^PS(53.1,+NEWORDER,.2),"^",3,4)=ORDCON_U_PRIORITY
+10 ;I $G(PRNTON) I $$UP^XLFSTR($G(PSGSCH))="NOW" S PRNTON=""
+11 IF $GET(PRNTON)
SET $PIECE(^PS(53.1,+NEWORDER,.2),"^",8)=PRNTON
+12 FOR DRGT="AD","SOL"
if $DATA(DRG(DRGT))
DO PTD531
+13 SET PSJOSTOP=$GET(@("^PS(55,"_PSJHLDFN_",""IV"","_+PREON_",0)"))
SET PSJOSTOP=$PIECE(PSJOSTOP,"^",3)
Begin DoDot:1
+14 NEW IVND
SET IVND=$GET(^PS(53.1,+NEWORDER,0))
DO REN531(NEWORDER,$PIECE(IVND,"^",14),$PIECE(ND,"^",2),PSJOSTOP,PSJHLDFN)
End DoDot:1
+15 QUIT
PTD531 ; Move drug data from local array into 53.1
+1 KILL ^PS(53.1,+NEWORDER,DRGT)
SET ^PS(53.1,+NEWORDER,DRGT,0)=$SELECT(DRGT="AD":"^53.157PA^0^0",1:"^53.158PA^0^0")
+2 FOR X=0:0
SET X=$ORDER(DRG(DRGT,X))
if 'X
QUIT
Begin DoDot:1
+3 SET X1=$PIECE(DRG(DRGT,X),U)
SET Y=^PS(53.1,+NEWORDER,DRGT,0)
SET $PIECE(Y,U,3)=$PIECE(Y,U,3)+1
SET DRG=$PIECE(Y,U,3)
SET $PIECE(Y,U,4)=$PIECE(Y,U,4)+1
+4 SET ^PS(53.1,+NEWORDER,DRGT,0)=Y
SET Y=+X1_U_$PIECE(DRG(DRGT,X),U,3)
if DRGT="AD"
SET $PIECE(Y,U,3)=$PIECE(DRG(DRGT,X),U,4)
SET ^PS(53.1,+NEWORDER,DRGT,+DRG,0)=Y
SET ^PS(53.1,+NEWORDER,DRGT,"B",+X1,+DRG)=""
End DoDot:1
+5 IF $GET(P("RES"))="R"
IF ($GET(ND(0))]"")
DO REN531(+NEWORDER,$PIECE(ND(0),"^",14),$PIECE(ND(0),"^",2),$GET(P(3)),$GET(DFN))
+6 QUIT
+7 ;
ENRNAT(OWD,NWD,SC,OAT) ;Determine admin times for renewal orders.
+1 ;OWD=ORIGINAL W,NWD=NEW WD LOCATION, SC=SCHEDULE, OAT=ORDER ADMIN TIMES
+2 NEW OWAT,SCP,X,Y,OOAT
+3 SET OOAT=OAT
SET SCP=+$ORDER(^PS(51.1,"APPSJ",+SC,0))
SET WAT=$PIECE($GET(^PS(51.1,SCP,1,+$GET(OWD),0)),U,2)
+4 FOR X="WAT","OAT"
FOR Y=1:1
if $LENGTH(@X)>240!($PIECE(@X,"-",Y)="")
QUIT
SET $PIECE(@X,"-",Y)=$PIECE(@X,"-",Y)_$EXTRACT("0000",1,4-$LENGTH($PIECE(@X,"-",Y)))
+5 IF OAT'=WAT
QUIT OOAT
+6 SET X=$PIECE($GET(^PS(51.1,+SCP,1,NWD,0)),U,2)
IF X
QUIT X
+7 QUIT OOAT
+8 ;
GTDRG ; Get drug info and place in DRG(.
+1 FOR DRGT="AD","SOL"
SET FIL=$SELECT(DRGT="AD":52.6,1:52.7)
FOR Y=0:0
SET Y=$ORDER(^PS(55,PSJHLDFN,"IV",+PREON,DRGT,Y))
if 'Y
QUIT
Begin DoDot:1
+2 ;Naked reference ^(Y,0) below refers to full global reference ^PS(55,PSJHLDFN,"IV",+PREON,DRGT,Y)) above at GTDRG+1
+3 SET DRG=$GET(^(Y,0))
SET ND=$GET(^PS(FIL,+DRG,0))
SET (DRGI,DRG(DRGT,0))=$GET(DRG(DRGT,0))+1
SET DRG(DRGT,+DRGI)=+DRG_U_$PIECE(ND,U)_U_$PIECE(DRG,U,2)_U_$PIECE(DRG,U,3)_U_$PIECE(ND,U,13)_U_$PIECE(ND,U,11)
End DoDot:1
+4 QUIT
+5 ;
REN531(PSGORD,PSGDT,PSGOEPR,PSGOFD,PSGP) ;
+1 if 'PSGORD!'PSGDT!'PSGOEPR!'PSGOFD!'PSGP
QUIT
+2 NEW DUP,PSGOLDPR
IF $GET(PREON)
Begin DoDot:1
+3 if $DATA(^PS(53.1,+PSGORD,14,"B",+PSGDT))
SET DUP=1
QUIT
End DoDot:1
if $GET(DUP)
QUIT
+4 if $GET(PREON)["U"
SET PSGOLDPR=$PIECE($GET(^PS(55,PSGP,5,+PREON,0)),"^",2)
+5 if $GET(PREON)["V"
SET PSGOLDPR=$PIECE($GET(^PS(55,PSGP,"IV",+PREON,0)),"^",6)
+6 KILL DR,DA,DIC,DIE,DD,DO
SET DIC="^PS(53.1,"_+PSGORD_",14,"
SET DIC(0)="L"
SET DIC("P")="53.1114DA"
SET ND14=$GET(@(DIC_"0)"))
SET DINUM=$PIECE(ND14,"^",3)+1
SET DA(2)=PSGP
SET DA(1)=+PSGORD
Begin DoDot:1
+7 SET DIC("DR")=".01////"_$GET(PSGDT)_";1////"_$GET(DUZ)_";2////"_$SELECT($GET(PSGOLDPR):$GET(PSGOLDPR),1:$GET(PSGOEPR))_";3////"_$GET(PSGOFD)
SET X=$GET(PSGDT)
DO FILE^DICN
End DoDot:1
+8 KILL DO,DINUM
+9 IF $GET(PREON)["U"
IF $DATA(^PS(55,PSGP,5,+PREON,15,1))
Begin DoDot:1
+10 NEW PSJSYSP
SET PSJSYSP=$JOB
DO GETSI^PSJBCMA5(PSGP,PREON)
IF $DATA(^PS(53.45,$JOB,5))
DO FILESI^PSJBCMA5(PSGP,$SELECT(PSGORD=+PSGORD:+PSGORD_"P",1:PSGORD))
End DoDot:1
+11 IF $GET(PREON)["V"
IF $DATA(^PS(55,PSGP,"IV",+PREON,10,1))
Begin DoDot:1
+12 NEW PSJSYSP
SET PSJSYSP=$JOB
DO GETOPI^PSJBCMA5(PSGP,PREON)
IF $DATA(^PS(53.45,$JOB,6))
DO FILEOPI^PSJBCMA5(PSGP,$SELECT(PSGORD=+PSGORD:+PSGORD_"P",1:PSGORD))
End DoDot:1
+13 QUIT
+14 ;
CHK(X,Y,Z) ;Check for required fields
+1 ; Input: X="^^"_MED ROUTE_"^^^^"_SCH TYPE
+2 ; Y=ORDERABLE ITEM_"^"_DOSAGE ORDERED
+3 ; Z=SCHEDULE_"^"_START DATE/TIME_"^^"_STOP DATE/TIME
+4 if '$DATA(^PS(50.7,+Y,0))
SET CHK=1
+5 IF ND=""
SET CHK=CHK_23
+6 IF '$TEST
SET CHK=CHK_$SELECT($PIECE(X,"^",3):"",1:2)_$SELECT($PIECE(X,"^",7)]"":"",1:3)
+7 KILL PSGDFLG,PSGPFLG
SET PSGDI=0
+8 if '$$DDOK^PSJHL10("^TMP(""PSB"","_$JOB_",700,",+Y)
SET CHK=CHK_7
+9 ;
CHKM ;
+1 if 'CHK
QUIT
+2 NEW MSG2
+3 SET MSG="THE FOLLOWING "_$SELECT($LENGTH(CHK)>1:"ARE",1:"IS")_" EITHER INVALID OR MISSING FROM THIS ORDER:"
FOR X=1:1:7
if CHK[X
SET MSG2=$PIECE("ORDERABLE ITEM^MED ROUTE^SCHEDULE TYPE^SCHEDULE^START DATE/TIME^STOP DATE/TIME^DISPENSE DRUG","^",X)
+4 SET PSREASON=MSG_MSG2
+5 QUIT
