ORMFN ; SLC/MKB - MFN msg router ;Nov 23, 2020@15:02:34
;;3.0;ORDER ENTRY/RESULTS REPORTING;**26,97,94,176,215,243,280,350,471,487,539**;Dec 17, 1997;Build 41
;
;
;
EN(MSG) ; -- main entry point for OR ITEM RECEIVE
N ORMSG,ORNMSP,ORDG,LEN,MSH,MFI,MFE,ZPKG,ZSY,NTE,ORMFE,ORDITEM,ORACTION,ORDIFN,ORFIEN,ORFLD,ORFDA,NUM,VALUE,X,Y,DA,DIC,DIK,SYS,ZLC,LAST,NAME,ID,INACTIVE,I,ORY,NEXT,DD,DO
;AGP Create a before and after temp global for compares by other protocols
K ^TMP($J,"OR OI BEFORE"),^TMP($J,"OR OI AFTER"),^TMP($J,"OR OI NEW")
S ORMSG=$G(MSG,"MSG") Q:'$O(@ORMSG@(0)) ; msg array root
N ORNOW S ORNOW=$$NOW^XLFDT ;M ^XTMP("OR ITEM RECEIVE",ORNOW)=@ORMSG
MSH S MSH=0 F S MSH=$O(@ORMSG@(MSH)) Q:MSH'>0 Q:$E(@ORMSG@(MSH),1,3)="MSH"
Q:'MSH S MSH=MSH_U_@ORMSG@(MSH)
S X=$P(MSH,"|",3) S:X="RADIOLOGY" X="IMAGING"
S ORDG=$O(^ORD(100.98,"B",X,0)),ORNMSP=$$NMSP(X) Q:'$L(ORNMSP)
S MFI=$O(@ORMSG@(+MSH)) Q:$E(@ORMSG@(MFI),1,3)'="MFI" ; error
MFE S MFE=+MFI ; ** loop through each MFE segment
F S MFE=$O(@ORMSG@(+MFE)) Q:MFE'>0 I $E(@ORMSG@(MFE),1,3)="MFE" D
. K ORFLD,ORFDA
. S MFE=MFE_U_@ORMSG@(MFE),ORMFE=$P(MFE,"|",2),INACTIVE=$P(MFE,"|",4)
. S ORDITEM=$P(MFE,"|",5),NAME=$TR($P(ORDITEM,U,5),"~"," ")
. ;AGP remove automatic stripping of trailing spaces
. ;S LEN=$L(NAME) I $E(NAME,LEN)=" " S NAME=$E(NAME,1,(LEN-1))
. S ID=$P(ORDITEM,U,4)_";"_$P(ORDITEM,U,6)
. S ORDIFN=+$O(^ORD(101.43,"ID",ID,0)),ORFIEN=ORDIFN_","
. S ORACTION=$S(ORMFE="MAD":1,(ORMFE="MAC")&('ORDIFN):1,(ORMFE="MUP")&('ORDIFN):1,'ORDIFN:0,ORMFE="MAC":2,ORMFE="MUP":2,ORMFE="MDC":3,ORMFE="MDL":3,1:0) ; 1=add, 2=change, 3=delete (inactivate)
. Q:'ORACTION ; 0=error
. I ORACTION=3 S ORFDA(101.43,ORFIEN,.1)=$S(INACTIVE:$$HL7TFM^XLFDT(INACTIVE),1:$$NOW^XLFDT) D FILE^DIE("K","ORFDA") Q
ADD . I ORACTION=1,'ORDIFN D Q:'ORDIFN ;create item if it doesn't exist
. . S ORDIFN=$$CREATE(NAME),ORFIEN=ORDIFN_","
. . S ORFDA(101.43,ORFIEN,5)=+ORDG
. . I ORDIFN>0 S ^TMP($J,"OR OI NEW",ORDIFN)=""
. I '$D(^TMP($J,"OR OI NEW",ORDIFN)) M ^TMP($J,"OR OI BEFORE",ORDIFN)=^ORD(101.43,ORDIFN)
. S ORFLD(.01)=NAME,ORFLD(1.1)=NAME,ORFLD(2)=ID,ORFLD(3)=$P(ORDITEM,U)
. I $D(^TMP($J,"OR OI BEFORE",ORDIFN,9,"AQO")) D
. . ;save orderable item quick order restriction
. . M ^TMP($J,"ORCM QO",ORDIFN)=^TMP($J,"OR OI BEFORE",ORDIFN,9,"AQO")
. S SYS=$P(ORDITEM,U,3),ORFLD(4)=$S(+SYS=99:$E(SYS,3,99),1:SYS)
. S ORFLD(.1)=$S(ORMFE="MAC":"@",(ORMFE="MUP")&('INACTIVE):"@",INACTIVE:$$HL7TFM^XLFDT(INACTIVE),1:"")
. F NUM=.01,.1,1.1,2,3,4 S VALUE=$S(ORFLD(NUM)="":"@",1:ORFLD(NUM)) D VAL^DIE(101.43,ORFIEN,NUM,"F",VALUE,.ORY,"ORFDA")
ZPKG . S LAST=+MFE,ZPKG=$O(@ORMSG@(+MFE))
. I ZPKG,$E(@ORMSG@(ZPKG),1,3)=("Z"_ORNMSP) S ZPKG=ZPKG_U_@ORMSG@(ZPKG),LAST=+ZPKG D @ORNMSP ; ZXX segment
. D FILE^DIE("K","ORFDA") ; file data
ZLC . S NEXT=$O(@ORMSG@(LAST)) I NEXT,$E(@ORMSG@(NEXT),1,3)="ZLC" D
. . N COMP,CID,CODE,CSYS
. . K DA,^ORD(101.43,ORDIFN,10) ;S DIC("P")=$P(^DD(101.43,10,0),U,2)
. . S DA(1)=ORDIFN,DIC="^ORD(101.43,"_DA(1)_",10,",DIC(0)="L",ZLC=LAST
. . F S ZLC=$O(@ORMSG@(ZLC)) Q:ZLC'>0 Q:$E(@ORMSG@(ZLC),1,3)'="ZLC" D
. . . S COMP=$P(@ORMSG@(ZLC),"|",5),X=$P(COMP,U,5) I X="" S LAST=ZLC Q
. . . S CID=$P(COMP,U,4)_";"_$P(COMP,U,6) K DIC("DR"),DO,DD
. . . S CODE=$P(COMP,U),CSYS=$P(COMP,U,3) S:+CSYS=99 CSYS=$E(CSYS,3,99)
. . . S DIC("DR")="2///^S X=CID;3///^S X=CODE;4///^S X=CSYS"
. . . D FILE^DICN S LAST=ZLC
ZSY . I $D(^ORD(101.43,ORDIFN,2)) D ; kill old ones first
. . S DA(1)=ORDIFN,DIK="^ORD(101.43,"_DA(1)_",2,"
. . S DA=0 F S DA=$O(^ORD(101.43,DA(1),2,DA)) Q:DA'>0 D ^DIK
. . K ^ORD(101.43,ORDIFN,2),DIK,DA
. S NEXT=$O(@ORMSG@(LAST)) I NEXT,$E(@ORMSG@(NEXT),1,3)="ZSY" D
. . K DA,DIC S DA(1)=ORDIFN,DIC="^ORD(101.43,"_DA(1)_",2,"
. . S DIC(0)="L",ZSY=LAST ;,DIC("P")=$P(^DD(101.43,1,0),U,2)
. . F S ZSY=$O(@ORMSG@(+ZSY)) Q:ZSY'>0 Q:$E(@ORMSG@(ZSY),1,3)'="ZSY" D
. . . S X=$P(@ORMSG@(ZSY),"|",3),LAST=ZSY
. . . K DD,DO D:$L(X) FILE^DICN
NTE . K ^ORD(101.43,ORDIFN,8) ; replace text
. S NEXT=$O(@ORMSG@(LAST)) I NEXT,$E(@ORMSG@(NEXT),1,3)="NTE" D
. . S NTE=LAST,DA=0
. . F S NTE=$O(@ORMSG@(NTE)) Q:NTE'>0 Q:$E(@ORMSG@(NTE),1,3)'="NTE" S DA=DA+1,^ORD(101.43,ORDIFN,8,DA,0)=$P(@ORMSG@(NTE),"|",4) I $O(@ORMSG@(NTE,0)) D
. . . S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S DA=DA+1,^ORD(101.43,ORDIFN,8,DA,0)=@ORMSG@(NTE,I)
. . S ^ORD(101.43,ORDIFN,8,0)="^^"_DA_U_DA_U_DT_U
. I '$D(^TMP($J,"OR OI NEW",ORDIFN)) M ^TMP($J,"OR OI AFTER",ORDIFN)=^ORD(101.43,ORDIFN)
. ;
. ;if orderable item quick order restriction previously on orderable item, replace it
. ;
. ;QO section is called repeatedly for IV entries
. ;At final call to this section, PSSQOX is set to 0 by routine PSSVIDRG.
. ;
. I $D(^TMP($J,"ORCM QO",ORDIFN)),'$G(PSSQOX) D QO
Q
;
QO ;replace quick order restriction(s)
N ORGRPX,DA,DIR,DIE,DR
S ORGRPX=""
F S ORGRPX=$O(^TMP($J,"ORCM QO",ORDIFN,ORGRPX)) Q:ORGRPX="" D
. Q:$D(^ORD(101.43,ORDIFN,9,"AQO",ORGRPX))
. S DA=$P(ORGRPX,"S.",2),DA=$O(^ORD(101.43,ORDIFN,9,"B",DA,0))
. Q:DA=""
. S DA(1)=ORDIFN
. S DR="2///YES",DIE="^ORD(101.43,"_DA(1)_",9,"
. D ^DIE
K ^TMP($J,"ORCM QO",ORDIFN)
Q
;
NMSP(NAME) ; -- returns namespace for package
I NAME="RADIOLOGY" Q "RA"
I NAME="IMAGING" Q "RA"
I NAME="LABORATORY" Q "LR"
I NAME="DIETETICS" Q "FH"
I NAME="PHARMACY" Q "PS"
I NAME="CONSULTS" Q "CS"
I NAME="PROCEDURES" Q "CS"
Q ""
;
CREATE(X) ; -- Create new item in #101.43
Q:'$L($G(X)) 0 N HDR,LAST,TOTAL,I
L +^ORD(101.43,0):1 Q:'$T 0
S HDR=$G(^ORD(101.43,0)) Q:HDR="" 0
S LAST=$P(HDR,U,3),TOTAL=$P(HDR,U,4)
F I=(LAST+1):1 Q:'$D(^ORD(101.43,I,0))
S ^ORD(101.43,I,0)=X,X=$E(X,1,30),^ORD(101.43,"B",$$UP^XLFSTR(X),I)=""
S $P(^ORD(101.43,0),U,3,4)=I_U_(TOTAL+1)
L -^ORD(101.43,0)
Q I
;
FH ; -- Dietetics
S X=$P(ZPKG,"|",2),ORFLD(111.1)=$S(X="":"@",1:X)
S X=$P(ZPKG,"|",3),ORFLD(111.2)=$S(X="":"@",1:X)
S X=$P(ZPKG,"|",5),ORFLD(111.3)=$S(X="":"@",1:X)
F NUM=111.1,111.2,111.3 D VAL^DIE(101.43,ORFIEN,NUM,"F",ORFLD(NUM),.ORY,"ORFDA")
K ^ORD(101.43,ORDIFN,8) S X=$P(ZPKG,"|",4)
I $L(X) S ^ORD(101.43,ORDIFN,8,0)="^^1^1^"_DT_U,^(1,0)=X
Q
;
LR ; -- Laboratory
S X=$P(ZPKG,"|",2),ORFLD(60.1)=$S(X="":"@",1:X)
S X=$P(ZPKG,"|",3),ORFLD(60.2)=$S(X="":"@",1:X)
;S X=$P(ZPKG,"|",4),ORFLD(60.3)=$S(X="":"@",1:X)
S X=$P(ZPKG,"|",5),ORFLD(60.6)=$S(X="":"@",1:X)
S X=$P(ZPKG,"|",6),ORFLD(60.4)=$S(X="":"@",1:X)
S X=$P(ZPKG,"|",7),ORFLD(60.5)=$S(X="":"@",1:X)
S X=$P(ZPKG,"|",8),ORFLD(6)=$S(X="":"@",1:X)
S X=$P(ZPKG,"|",9),ORFLD(60.7)=$S(X="":"@",1:X)
F NUM=6,60.1,60.2,60.4,60.5,60.6,60.7 D VAL^DIE(101.43,ORFIEN,NUM,"F",ORFLD(NUM),.ORY,"ORFDA")
I $G(ORFLD(60.6))?1(1"SP",1"CY",1"EM") D
. S ORFDA(101.43,ORFIEN,5)=$O(^ORD(100.98,"B","ANATOMIC PATHOLOGY",0))
Q
;
PS ; -- Pharmacy
N ROUTE,PSO,S3,ORPSVAC,ORPSOI
K ^TMP("$J","ORMFN")
S X=$P(ZPKG,"|",2)
;S ORFDA(101.43,ORFIEN,50.1)=$S(X'["I":0,$L($P($P(ORDITEM,U,5),"~",3)):2,1:1)
S ORFDA(101.43,ORFIEN,50.1)=$S(X["V":2,X["I":1,1:0) ;inpt or iv med
S ORFDA(101.43,ORFIEN,50.2)=(X["O") ;outpt med
S ORFDA(101.43,ORFIEN,50.3)=(X["B") ;fluid base/soln
S ORFDA(101.43,ORFIEN,50.4)=(X["A") ;fluid additive
S ORFDA(101.43,ORFIEN,50.7)=(X["N") ;non-VA med
;Supply Items
D
. S ORPSOI=+$P($P(MFE,"|",5),"^",4) D DRGIEN^PSS50P7(ORPSOI,"","ORMFN")
. I ^TMP($J,"ORMFN",0)'>0 Q
. S S3=0,ORFDA(101.43,ORFIEN,50.5)=0
. F S S3=$O(^TMP($J,"ORMFN",S3)) Q:'S3 D
.. D ZERO^PSS50(S3,,,,,"ORMFN")
.. I ^TMP($J,"ORMFN",0)'>0 Q
.. S ORPSVAC=$G(^TMP($J,"ORMFN",S3,2))
.. I ORPSVAC?1"XA".E!(ORPSVAC?1"XX".E)!(ORPSVAC="DX900"&($G(^TMP($J,"ORMFN",S3,3))["S")) S ORFDA(101.43,ORFIEN,50.5)=1
S X=$P(ZPKG,"|",3),ORFDA(101.43,ORFIEN,50.6)=$S(X:1,1:0)
;Check for default med route
;S ROUTE=$$MEDROUTE
;I ROUTE>0 S ORFDA(101.43,ORFIEN,50.8)=ROUTE
Q
;
MEDROUTE() ;
N CNT,ROUTE
S CNT=0,ROUTE=0
F S CNT=$O(@ORMSG@(CNT)) Q:CNT'>0 D
.I $P($G(@ORMSG@(CNT)),"|")'="ZPB" Q
.S ROUTE=+$P($G(@ORMSG@(CNT)),"|",4)
Q ROUTE
;
RA ; -- Radiology/Nuc Medicine
S X=$P(ZPKG,"|",4),ORFLD(6)=$S(X="":"@",1:X)
S X=$P(ZPKG,"|",5),ORFLD(71.1)=$S(X="":"@",1:X)
S X=$P(ZPKG,"|",7),ORFLD(71.2)=$S(X="":"@",1:X)
S X=$P(ZPKG,"|",2),ORFLD(71.3)=$S(X="":"@",1:X)
S ORFLD(71.4)=$S($P(ZPKG,"|",6)="Y":1,1:0)
S ORFLD(7)=$S($P(ZPKG,"|",3)="Y":2,1:1)
F NUM=6,7,71.1,71.2,71.3,71.4 D VAL^DIE(101.43,ORFIEN,NUM,"F",ORFLD(NUM),.ORY,"ORFDA")
Q
;
CS ; -- Consults/Requests
S X=$P(ZPKG,"|",2),ORFLD(123.1)=$S(X="":"@",1:X)
D VAL^DIE(101.43,ORFIEN,123.1,"F",ORFLD(123.1),.ORY,"ORFDA")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORMFN 8654 printed Nov 22, 2024@17:41:55 Page 2
ORMFN ; SLC/MKB - MFN msg router ;Nov 23, 2020@15:02:34
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**26,97,94,176,215,243,280,350,471,487,539**;Dec 17, 1997;Build 41
+2 ;
+3 ;
+4 ;
EN(MSG) ; -- main entry point for OR ITEM RECEIVE
+1 NEW ORMSG,ORNMSP,ORDG,LEN,MSH,MFI,MFE,ZPKG,ZSY,NTE,ORMFE,ORDITEM,ORACTION,ORDIFN,ORFIEN,ORFLD,ORFDA,NUM,VALUE,X,Y,DA,DIC,DIK,SYS,ZLC,LAST,NAME,ID,INACTIVE,I,ORY,NEXT,DD,DO
+2 ;AGP Create a before and after temp global for compares by other protocols
+3 KILL ^TMP($JOB,"OR OI BEFORE"),^TMP($JOB,"OR OI AFTER"),^TMP($JOB,"OR OI NEW")
+4 ; msg array root
SET ORMSG=$GET(MSG,"MSG")
if '$ORDER(@ORMSG@(0))
QUIT
+5 ;M ^XTMP("OR ITEM RECEIVE",ORNOW)=@ORMSG
NEW ORNOW
SET ORNOW=$$NOW^XLFDT
MSH SET MSH=0
FOR
SET MSH=$ORDER(@ORMSG@(MSH))
if MSH'>0
QUIT
if $EXTRACT(@ORMSG@(MSH),1,3)="MSH"
QUIT
+1 if 'MSH
QUIT
SET MSH=MSH_U_@ORMSG@(MSH)
+2 SET X=$PIECE(MSH,"|",3)
if X="RADIOLOGY"
SET X="IMAGING"
+3 SET ORDG=$ORDER(^ORD(100.98,"B",X,0))
SET ORNMSP=$$NMSP(X)
if '$LENGTH(ORNMSP)
QUIT
+4 ; error
SET MFI=$ORDER(@ORMSG@(+MSH))
if $EXTRACT(@ORMSG@(MFI),1,3)'="MFI"
QUIT
MFE ; ** loop through each MFE segment
SET MFE=+MFI
+1 FOR
SET MFE=$ORDER(@ORMSG@(+MFE))
if MFE'>0
QUIT
IF $EXTRACT(@ORMSG@(MFE),1,3)="MFE"
Begin DoDot:1
+2 KILL ORFLD,ORFDA
+3 SET MFE=MFE_U_@ORMSG@(MFE)
SET ORMFE=$PIECE(MFE,"|",2)
SET INACTIVE=$PIECE(MFE,"|",4)
+4 SET ORDITEM=$PIECE(MFE,"|",5)
SET NAME=$TRANSLATE($PIECE(ORDITEM,U,5),"~"," ")
+5 ;AGP remove automatic stripping of trailing spaces
+6 ;S LEN=$L(NAME) I $E(NAME,LEN)=" " S NAME=$E(NAME,1,(LEN-1))
+7 SET ID=$PIECE(ORDITEM,U,4)_";"_$PIECE(ORDITEM,U,6)
+8 SET ORDIFN=+$ORDER(^ORD(101.43,"ID",ID,0))
SET ORFIEN=ORDIFN_","
+9 ; 1=add, 2=change, 3=delete (inactivate)
SET ORACTION=$SELECT(ORMFE="MAD":1,(ORMFE="MAC")&('ORDIFN):1,(ORMFE="MUP")&('ORDIFN):1,'ORDIFN:0,ORMFE="MAC":2,ORMFE="MUP":2,ORMFE="MDC":3,ORMFE="MDL":3,1:0)
+10 ; 0=error
if 'ORACTION
QUIT
+11 IF ORACTION=3
SET ORFDA(101.43,ORFIEN,.1)=$SELECT(INACTIVE:$$HL7TFM^XLFDT(INACTIVE),1:$$NOW^XLFDT)
DO FILE^DIE("K","ORFDA")
QUIT
ADD ;create item if it doesn't exist
IF ORACTION=1
IF 'ORDIFN
Begin DoDot:2
+1 SET ORDIFN=$$CREATE(NAME)
SET ORFIEN=ORDIFN_","
+2 SET ORFDA(101.43,ORFIEN,5)=+ORDG
+3 IF ORDIFN>0
SET ^TMP($JOB,"OR OI NEW",ORDIFN)=""
End DoDot:2
if 'ORDIFN
QUIT
+4 IF '$DATA(^TMP($JOB,"OR OI NEW",ORDIFN))
MERGE ^TMP($JOB,"OR OI BEFORE",ORDIFN)=^ORD(101.43,ORDIFN)
+5 SET ORFLD(.01)=NAME
SET ORFLD(1.1)=NAME
SET ORFLD(2)=ID
SET ORFLD(3)=$PIECE(ORDITEM,U)
+6 IF $DATA(^TMP($JOB,"OR OI BEFORE",ORDIFN,9,"AQO"))
Begin DoDot:2
+7 ;save orderable item quick order restriction
+8 MERGE ^TMP($JOB,"ORCM QO",ORDIFN)=^TMP($JOB,"OR OI BEFORE",ORDIFN,9,"AQO")
End DoDot:2
+9 SET SYS=$PIECE(ORDITEM,U,3)
SET ORFLD(4)=$SELECT(+SYS=99:$EXTRACT(SYS,3,99),1:SYS)
+10 SET ORFLD(.1)=$SELECT(ORMFE="MAC":"@",(ORMFE="MUP")&('INACTIVE):"@",INACTIVE:$$HL7TFM^XLFDT(INACTIVE),1:"")
+11 FOR NUM=.01,.1,1.1,2,3,4
SET VALUE=$SELECT(ORFLD(NUM)="":"@",1:ORFLD(NUM))
DO VAL^DIE(101.43,ORFIEN,NUM,"F",VALUE,.ORY,"ORFDA")
ZPKG SET LAST=+MFE
SET ZPKG=$ORDER(@ORMSG@(+MFE))
+1 ; ZXX segment
IF ZPKG
IF $EXTRACT(@ORMSG@(ZPKG),1,3)=("Z"_ORNMSP)
SET ZPKG=ZPKG_U_@ORMSG@(ZPKG)
SET LAST=+ZPKG
DO @ORNMSP
+2 ; file data
DO FILE^DIE("K","ORFDA")
ZLC SET NEXT=$ORDER(@ORMSG@(LAST))
IF NEXT
IF $EXTRACT(@ORMSG@(NEXT),1,3)="ZLC"
Begin DoDot:2
+1 NEW COMP,CID,CODE,CSYS
+2 ;S DIC("P")=$P(^DD(101.43,10,0),U,2)
KILL DA,^ORD(101.43,ORDIFN,10)
+3 SET DA(1)=ORDIFN
SET DIC="^ORD(101.43,"_DA(1)_",10,"
SET DIC(0)="L"
SET ZLC=LAST
+4 FOR
SET ZLC=$ORDER(@ORMSG@(ZLC))
if ZLC'>0
QUIT
if $EXTRACT(@ORMSG@(ZLC),1,3)'="ZLC"
QUIT
Begin DoDot:3
+5 SET COMP=$PIECE(@ORMSG@(ZLC),"|",5)
SET X=$PIECE(COMP,U,5)
IF X=""
SET LAST=ZLC
QUIT
+6 SET CID=$PIECE(COMP,U,4)_";"_$PIECE(COMP,U,6)
KILL DIC("DR"),DO,DD
+7 SET CODE=$PIECE(COMP,U)
SET CSYS=$PIECE(COMP,U,3)
if +CSYS=99
SET CSYS=$EXTRACT(CSYS,3,99)
+8 SET DIC("DR")="2///^S X=CID;3///^S X=CODE;4///^S X=CSYS"
+9 DO FILE^DICN
SET LAST=ZLC
End DoDot:3
End DoDot:2
ZSY ; kill old ones first
IF $DATA(^ORD(101.43,ORDIFN,2))
Begin DoDot:2
+1 SET DA(1)=ORDIFN
SET DIK="^ORD(101.43,"_DA(1)_",2,"
+2 SET DA=0
FOR
SET DA=$ORDER(^ORD(101.43,DA(1),2,DA))
if DA'>0
QUIT
DO ^DIK
+3 KILL ^ORD(101.43,ORDIFN,2),DIK,DA
End DoDot:2
+4 SET NEXT=$ORDER(@ORMSG@(LAST))
IF NEXT
IF $EXTRACT(@ORMSG@(NEXT),1,3)="ZSY"
Begin DoDot:2
+5 KILL DA,DIC
SET DA(1)=ORDIFN
SET DIC="^ORD(101.43,"_DA(1)_",2,"
+6 ;,DIC("P")=$P(^DD(101.43,1,0),U,2)
SET DIC(0)="L"
SET ZSY=LAST
+7 FOR
SET ZSY=$ORDER(@ORMSG@(+ZSY))
if ZSY'>0
QUIT
if $EXTRACT(@ORMSG@(ZSY),1,3)'="ZSY"
QUIT
Begin DoDot:3
+8 SET X=$PIECE(@ORMSG@(ZSY),"|",3)
SET LAST=ZSY
+9 KILL DD,DO
if $LENGTH(X)
DO FILE^DICN
End DoDot:3
End DoDot:2
NTE ; replace text
KILL ^ORD(101.43,ORDIFN,8)
+1 SET NEXT=$ORDER(@ORMSG@(LAST))
IF NEXT
IF $EXTRACT(@ORMSG@(NEXT),1,3)="NTE"
Begin DoDot:2
+2 SET NTE=LAST
SET DA=0
+3 FOR
SET NTE=$ORDER(@ORMSG@(NTE))
if NTE'>0
QUIT
if $EXTRACT(@ORMSG@(NTE),1,3)'="NTE"
QUIT
SET DA=DA+1
SET ^ORD(101.43,ORDIFN,8,DA,0)=$PIECE(@ORMSG@(NTE),"|",4)
IF $ORDER(@ORMSG@(NTE,0))
Begin DoDot:3
+4 SET I=0
FOR
SET I=$ORDER(@ORMSG@(NTE,I))
if I'>0
QUIT
SET DA=DA+1
SET ^ORD(101.43,ORDIFN,8,DA,0)=@ORMSG@(NTE,I)
End DoDot:3
+5 SET ^ORD(101.43,ORDIFN,8,0)="^^"_DA_U_DA_U_DT_U
End DoDot:2
+6 IF '$DATA(^TMP($JOB,"OR OI NEW",ORDIFN))
MERGE ^TMP($JOB,"OR OI AFTER",ORDIFN)=^ORD(101.43,ORDIFN)
+7 ;
+8 ;if orderable item quick order restriction previously on orderable item, replace it
+9 ;
+10 ;QO section is called repeatedly for IV entries
+11 ;At final call to this section, PSSQOX is set to 0 by routine PSSVIDRG.
+12 ;
+13 IF $DATA(^TMP($JOB,"ORCM QO",ORDIFN))
IF '$GET(PSSQOX)
DO QO
End DoDot:1
+14 QUIT
+15 ;
QO ;replace quick order restriction(s)
+1 NEW ORGRPX,DA,DIR,DIE,DR
+2 SET ORGRPX=""
+3 FOR
SET ORGRPX=$ORDER(^TMP($JOB,"ORCM QO",ORDIFN,ORGRPX))
if ORGRPX=""
QUIT
Begin DoDot:1
+4 if $DATA(^ORD(101.43,ORDIFN,9,"AQO",ORGRPX))
QUIT
+5 SET DA=$PIECE(ORGRPX,"S.",2)
SET DA=$ORDER(^ORD(101.43,ORDIFN,9,"B",DA,0))
+6 if DA=""
QUIT
+7 SET DA(1)=ORDIFN
+8 SET DR="2///YES"
SET DIE="^ORD(101.43,"_DA(1)_",9,"
+9 DO ^DIE
End DoDot:1
+10 KILL ^TMP($JOB,"ORCM QO",ORDIFN)
+11 QUIT
+12 ;
NMSP(NAME) ; -- returns namespace for package
+1 IF NAME="RADIOLOGY"
QUIT "RA"
+2 IF NAME="IMAGING"
QUIT "RA"
+3 IF NAME="LABORATORY"
QUIT "LR"
+4 IF NAME="DIETETICS"
QUIT "FH"
+5 IF NAME="PHARMACY"
QUIT "PS"
+6 IF NAME="CONSULTS"
QUIT "CS"
+7 IF NAME="PROCEDURES"
QUIT "CS"
+8 QUIT ""
+9 ;
CREATE(X) ; -- Create new item in #101.43
+1 if '$LENGTH($GET(X))
QUIT 0
NEW HDR,LAST,TOTAL,I
+2 LOCK +^ORD(101.43,0):1
if '$TEST
QUIT 0
+3 SET HDR=$GET(^ORD(101.43,0))
if HDR=""
QUIT 0
+4 SET LAST=$PIECE(HDR,U,3)
SET TOTAL=$PIECE(HDR,U,4)
+5 FOR I=(LAST+1):1
if '$DATA(^ORD(101.43,I,0))
QUIT
+6 SET ^ORD(101.43,I,0)=X
SET X=$EXTRACT(X,1,30)
SET ^ORD(101.43,"B",$$UP^XLFSTR(X),I)=""
+7 SET $PIECE(^ORD(101.43,0),U,3,4)=I_U_(TOTAL+1)
+8 LOCK -^ORD(101.43,0)
+9 QUIT I
+10 ;
FH ; -- Dietetics
+1 SET X=$PIECE(ZPKG,"|",2)
SET ORFLD(111.1)=$SELECT(X="":"@",1:X)
+2 SET X=$PIECE(ZPKG,"|",3)
SET ORFLD(111.2)=$SELECT(X="":"@",1:X)
+3 SET X=$PIECE(ZPKG,"|",5)
SET ORFLD(111.3)=$SELECT(X="":"@",1:X)
+4 FOR NUM=111.1,111.2,111.3
DO VAL^DIE(101.43,ORFIEN,NUM,"F",ORFLD(NUM),.ORY,"ORFDA")
+5 KILL ^ORD(101.43,ORDIFN,8)
SET X=$PIECE(ZPKG,"|",4)
+6 IF $LENGTH(X)
SET ^ORD(101.43,ORDIFN,8,0)="^^1^1^"_DT_U
SET ^(1,0)=X
+7 QUIT
+8 ;
LR ; -- Laboratory
+1 SET X=$PIECE(ZPKG,"|",2)
SET ORFLD(60.1)=$SELECT(X="":"@",1:X)
+2 SET X=$PIECE(ZPKG,"|",3)
SET ORFLD(60.2)=$SELECT(X="":"@",1:X)
+3 ;S X=$P(ZPKG,"|",4),ORFLD(60.3)=$S(X="":"@",1:X)
+4 SET X=$PIECE(ZPKG,"|",5)
SET ORFLD(60.6)=$SELECT(X="":"@",1:X)
+5 SET X=$PIECE(ZPKG,"|",6)
SET ORFLD(60.4)=$SELECT(X="":"@",1:X)
+6 SET X=$PIECE(ZPKG,"|",7)
SET ORFLD(60.5)=$SELECT(X="":"@",1:X)
+7 SET X=$PIECE(ZPKG,"|",8)
SET ORFLD(6)=$SELECT(X="":"@",1:X)
+8 SET X=$PIECE(ZPKG,"|",9)
SET ORFLD(60.7)=$SELECT(X="":"@",1:X)
+9 FOR NUM=6,60.1,60.2,60.4,60.5,60.6,60.7
DO VAL^DIE(101.43,ORFIEN,NUM,"F",ORFLD(NUM),.ORY,"ORFDA")
+10 IF $GET(ORFLD(60.6))?1(1"SP",1"CY",1"EM")
Begin DoDot:1
+11 SET ORFDA(101.43,ORFIEN,5)=$ORDER(^ORD(100.98,"B","ANATOMIC PATHOLOGY",0))
End DoDot:1
+12 QUIT
+13 ;
PS ; -- Pharmacy
+1 NEW ROUTE,PSO,S3,ORPSVAC,ORPSOI
+2 KILL ^TMP("$J","ORMFN")
+3 SET X=$PIECE(ZPKG,"|",2)
+4 ;S ORFDA(101.43,ORFIEN,50.1)=$S(X'["I":0,$L($P($P(ORDITEM,U,5),"~",3)):2,1:1)
+5 ;inpt or iv med
SET ORFDA(101.43,ORFIEN,50.1)=$SELECT(X["V":2,X["I":1,1:0)
+6 ;outpt med
SET ORFDA(101.43,ORFIEN,50.2)=(X["O")
+7 ;fluid base/soln
SET ORFDA(101.43,ORFIEN,50.3)=(X["B")
+8 ;fluid additive
SET ORFDA(101.43,ORFIEN,50.4)=(X["A")
+9 ;non-VA med
SET ORFDA(101.43,ORFIEN,50.7)=(X["N")
+10 ;Supply Items
+11 Begin DoDot:1
+12 SET ORPSOI=+$PIECE($PIECE(MFE,"|",5),"^",4)
DO DRGIEN^PSS50P7(ORPSOI,"","ORMFN")
+13 IF ^TMP($JOB,"ORMFN",0)'>0
QUIT
+14 SET S3=0
SET ORFDA(101.43,ORFIEN,50.5)=0
+15 FOR
SET S3=$ORDER(^TMP($JOB,"ORMFN",S3))
if 'S3
QUIT
Begin DoDot:2
+16 DO ZERO^PSS50(S3,,,,,"ORMFN")
+17 IF ^TMP($JOB,"ORMFN",0)'>0
QUIT
+18 SET ORPSVAC=$GET(^TMP($JOB,"ORMFN",S3,2))
+19 IF ORPSVAC?1"XA".E!(ORPSVAC?1"XX".E)!(ORPSVAC="DX900"&($GET(^TMP($JOB,"ORMFN",S3,3))["S"))
SET ORFDA(101.43,ORFIEN,50.5)=1
End DoDot:2
End DoDot:1
+20 SET X=$PIECE(ZPKG,"|",3)
SET ORFDA(101.43,ORFIEN,50.6)=$SELECT(X:1,1:0)
+21 ;Check for default med route
+22 ;S ROUTE=$$MEDROUTE
+23 ;I ROUTE>0 S ORFDA(101.43,ORFIEN,50.8)=ROUTE
+24 QUIT
+25 ;
MEDROUTE() ;
+1 NEW CNT,ROUTE
+2 SET CNT=0
SET ROUTE=0
+3 FOR
SET CNT=$ORDER(@ORMSG@(CNT))
if CNT'>0
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(@ORMSG@(CNT)),"|")'="ZPB"
QUIT
+5 SET ROUTE=+$PIECE($GET(@ORMSG@(CNT)),"|",4)
End DoDot:1
+6 QUIT ROUTE
+7 ;
RA ; -- Radiology/Nuc Medicine
+1 SET X=$PIECE(ZPKG,"|",4)
SET ORFLD(6)=$SELECT(X="":"@",1:X)
+2 SET X=$PIECE(ZPKG,"|",5)
SET ORFLD(71.1)=$SELECT(X="":"@",1:X)
+3 SET X=$PIECE(ZPKG,"|",7)
SET ORFLD(71.2)=$SELECT(X="":"@",1:X)
+4 SET X=$PIECE(ZPKG,"|",2)
SET ORFLD(71.3)=$SELECT(X="":"@",1:X)
+5 SET ORFLD(71.4)=$SELECT($PIECE(ZPKG,"|",6)="Y":1,1:0)
+6 SET ORFLD(7)=$SELECT($PIECE(ZPKG,"|",3)="Y":2,1:1)
+7 FOR NUM=6,7,71.1,71.2,71.3,71.4
DO VAL^DIE(101.43,ORFIEN,NUM,"F",ORFLD(NUM),.ORY,"ORFDA")
+8 QUIT
+9 ;
CS ; -- Consults/Requests
+1 SET X=$PIECE(ZPKG,"|",2)
SET ORFLD(123.1)=$SELECT(X="":"@",1:X)
+2 DO VAL^DIE(101.43,ORFIEN,123.1,"F",ORFLD(123.1),.ORY,"ORFDA")
+3 QUIT
