- 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 Jan 18, 2025@03:08:16 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