OR3C100 ; SLC/MKB - Orders file conversion for CPRS/OE3 ;8/8/97 15:27
;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997
ORDERS(ORVP) ; -- Convert all orders for patient ORVP
N ORPARAM,ORIDT,ORDG,ORIFN,OR0,OR3,OR6,ORSTRT,ORSTOP,ORSTS,DC,DC0,ORACT,ORCAT,RIFN,ORYD,ORNOW,ORDA,CURR,I S U="^"
S ORPARAM=$$GET^XPAR("SYS","ORPF ACTIVE ORDERS CONTEXT HRS",1,"Q")
ORD1 S ORIDT=0 F S ORIDT=$O(^OR(100,"AO",ORVP,ORIDT)) Q:ORIDT'>0 S ORDG=0 F S ORDG=$O(^OR(100,"AO",ORVP,ORIDT,ORDG)) Q:ORDG'>0 S ORIFN=0 F S ORIFN=$O(^OR(100,"AO",ORVP,ORIDT,ORDG,ORIFN)) Q:ORIFN'>0 D
. S OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3)),OR6=$G(^(6)) G:'$L(OR0) QQ
. I 'ORVP!('$D(^DPT(+ORVP,0)))!('ORDG)!('$D(^ORD(100.98,+ORDG,0))) D CLEAN(ORIFN) G QQ ; bad record
. I $P(OR0,U,5)["ORD(101,",$P($G(^ORD(101,+$P(OR0,U,5),0)),U)?1"ORGY ".E S $P(^OR(100,ORIFN,3),U,8)=1 G QQ
. S ORSTRT=$P(OR3,U,6),ORSTOP=$P(OR0,U,9),ORSTS=$P(OR3,U,3)
. K DC,DC0,ORACT,ORCAT I $D(^OR(100,ORIFN,8)) D ; look for DC order
. . S RIFN=0 F S RIFN=$O(^OR(100,ORIFN,8,RIFN)) Q:RIFN'>0 I $D(^OR(100,RIFN,0)),"^1^2^11^"[(U_$P($G(^(3)),U,3)_U),$E($G(^(1,1,0)),1,2)="DC" S DC=RIFN
. S ORYD=$$ORYD(ORPARAM),ORNOW=$$NOW^XLFDT
NW . S ORDA=1,ORACT(ORDA,0)=$P(OR0,U,7)_"^NW^"_$P(OR3,U,7)_U_$P(OR3,U,13)_U_$P(OR3,U,10)_U_$P(OR3,U,12)_U_$P(OR3,U,14)_"^^^^^"_$$NATURE($P(OR0,U,12))_U_$P(OR0,U,6)_U_U_$S($P(OR3,U,3)=11:11,1:"")_U_$P(OR6,U,8,9) ; encrypt ES
. S ORACT("C","NW",ORDA)="",CURR=1 D ACT($P(OR0,U,7),$P(OR3,U,13))
. I ORSTS,"^1^2^7^14^99^"'[(U_ORSTS_U) D AC($P(OR0,U,7))
. I ORYD,"^1^2^7^"[(U_ORSTS_U),ORSTOP'<ORYD D AC($P(OR0,U,7))
. I $P(OR6,U)'="" S ORACT(ORDA,3)=$$FLAG(ORIFN)
. I ORSTS=11 D BUILD G SET ; build 4.5 nodes if unreleased
DC . I $G(DC) D ; add DC action
. . S ORDA=ORDA+1,DC0=$$DCACTION(DC),ORACT(ORDA,0)=DC0
. . S ORACT("C","DC",ORDA)="" D ACT($P(DC0,U),$P(DC0,U,4))
. . I $P(DC0,U,15)=11 D AC($P(DC0,U))
. . I $P(DC0,U,15)=13,ORYD,$P(DC0,U)'<ORYD D AC($P(DC0,U))
. . I $P($G(^OR(100,DC,6)),U)'="" S ORACT(ORDA,3)=$$FLAG(DC)
. . K ^OR(100,"AW",ORVP,ORDG,$S($P($G(^OR(100,DC,3)),U,6):$P(^(3),U,6),1:9999999),DC),^OR(100,DC) ; delete DC order
SET . I $P(OR0,U,14)=+$O(^DIC(9.4,"C","OR",0)) D ORG ; convert text orders
. S $P(OR0,U,8)=$P(OR3,U,6),$P(OR0,U,12)=$S($D(ORCAT):ORCAT,1:$$CLASS($P(OR0,U,10))),$P(OR0,U,16,17)=$S($P(OR3,U,13)=3:0,1:2)_U
. I $P(OR0,U,14)=+$O(^DIC(9.4,"C","GMRV",0)) S I=+$O(^DIC(9.4,"C","OR",0)) S:I $P(OR0,U,14)=I ; reset pkg to OR, for HL7 msgs
. S $P(OR3,U,7)=CURR F I=5,6,10,12,13,14,15 S $P(OR3,U,I)=""
. K ^OR(100,ORIFN,6),^(8),^(9) ; Flag/DC, Related Orders, Notifications
. S:$P(OR6,U,12) I=$$NATURE($P(OR6,U,11)),^OR(100,ORIFN,6)=$S(I:I,1:$P($G(DC0),U,12))_U_$P(OR6,U,12,13)
. S ^OR(100,ORIFN,0)=OR0,^(3)=OR3,^(8,0)="^100.008DA^"_ORDA_U_ORDA M ^OR(100,ORIFN,8)=ORACT
. I $D(^OR(100,ORIFN,5)) M ^OR(100,ORIFN,8,1,5)=^OR(100,ORIFN,5) K ^OR(100,ORIFN,5)
. I ORSTRT,ORSTRT>ORNOW,ORSTS=8 S ^OR(100,"AD",ORSTRT,ORIFN)=""
. I ORSTOP,"^1^2^7^12^13^"'[(U_ORSTS_U) S ^OR(100,"AE",ORSTOP,ORIFN)=""
QQ . K ^OR(100,"AO",ORVP,ORIDT,ORDG,ORIFN)
Q
;
DCACTION(IFN) ; -- Returns related DC order
N OR0,OR3,OR6,X S OR0=$G(^OR(100,IFN,0)),OR3=$G(^(3)),OR6=$G(^(6))
S X=$P(OR0,U,7)_"^DC^"_$P(OR3,U,7)_U_$P(OR3,U,13)_U_$P(OR3,U,10)_U_$P(OR3,U,12)_U_$P(OR3,U,14)_"^^^^^"_$$NATURE($P(OR0,U,12))_U_$P(OR0,U,6)_U_U_$S($P(OR3,U,3)=11:11,$P(OR3,U,3)=1:13,1:"")_U_$P(OR6,U,8,9)
Q X
;
FLAG(IFN) ; -- Returns fields for flag
N OR6,X S OR6=$G(^OR(100,IFN,6))
S X=$P(OR6,U)_U_$P(OR6,U,4)_U_$P(OR6,U,2,3)_U_$P(OR6,U,7)_U_$P(OR6,U,5,6),$P(OR6,U,1,7)="^^^^^^"
Q X
;
NATURE(X) ; -- Returns ptr to #100.02 for nature X
N Y S Y=$S(X="":"",1:$O(^ORD(100.02,"C",X,0)))
Q Y
;
AC(X) ; -- Set AC xref
S:X ^OR(100,"AC",ORVP,9999999-X,ORIFN,ORDA)=""
Q
;
ACT(X,SIG) ; -- ACT & AS xrefs
S:X ^OR(100,"ACT",ORVP,9999999-X,ORDG,ORIFN,ORDA)="",^OR(100,"AF",X,ORIFN,ORDA)=""
S:$G(SIG)=2 ^OR(100,"AS",ORVP,9999999-X,ORIFN,ORDA)=""
Q
;
CLASS(LOC) ; -- Returns patient classification for order
N X S X=$S($D(ORCAT):ORCAT,1:"I")
I +LOC,$P($G(^SC(+LOC,0)),U,3)'="W" S X="O"
Q X
;
ORYD(Y) ; -- Returns Current Orders context hours
; Y = ORPF ACTIVE ORDERS CONTEXT HRS parameter value
N X,X1,X2,X3,%,%H
I Y S X=$H,X=+X*24+($P(X,",",2)/3600),X2=Y,X1=X-X2,X3=X1#24,X1=X1\24,X2=$J(X3*3600,0,0),%H=X1_","_X2 D YMD^%DTC S Y=+(X_%)
Q Y
;
CLEAN(DA) ; -- Clean up bad entries
M ^ORYX("ORDERS",DA)=^OR(100,DA)
N DIK S DIK="^OR(100," D ^DIK
Q
;
BUILD ; -- Build Response multiple for unreleased orders
N ORPK,ORPKG,ORDIALOG,ORQUIT
S ORPKG=$$NMSP^ORCD($P(OR0,U,14)) Q:"PS"[ORPKG
S ORPK=$G(^OR(100,ORIFN,4)) K ^(4),^TMP("ORWORD",$J)
D ^OR3C100A Q:$G(ORQUIT) D RESPONSE^ORCSAVE ; build, save responses
S:$G(ORDIALOG) $P(OR0,U,5)=+ORDIALOG_";ORD(101.41,"
K ^TMP("ORWORD",$J)
Q
;
ORG ; -- Convert generic orders from protocols to dialogs
I '$O(^OR(100,ORIFN,4.5,0)) D WP Q
N PITEM,DITEM,DA,PDA,PTR S PITEM=$P(OR3,U,4)
I $S('PITEM:1,PITEM'[";ORD(101,":1,'$D(^ORD(101,+PITEM,0)):1,1:0) D WP Q
S DITEM=$$ITEM^ORCONVRT(+PITEM) I 'DITEM D WP Q
S DA=0 F S DA=$O(^OR(100,ORIFN,4.5,DA)) Q:DA'>0 S PDA=+$G(^(DA,0)) D
. I 'PDA K ^OR(100,ORIFN,4.5,DA) Q
. S PTR=+$P($G(^ORD(101.41,DITEM,10,DA,0)),U,2)
. S:PTR ^OR(100,ORIFN,4.5,DA,0)=PDA_U_PTR_"^1"
S $P(^OR(100,ORIFN,0),U,5)=DITEM_";ORD(101.41,"
Q
;
WP ; -- Save as Word Processing dialog
N WP S WP=+$O(^ORD(101.41,"AB","OR GTX WORD PROCESSING 1",0))
K ^OR(100,ORIFN,4.5) S ^(4.5,0)="^100.045A^1^1",^(1,0)="1^"_WP_"^1"
M ^OR(100,ORIFN,4.5,1,2)=^OR(100,ORIFN,1)
N X S X=$G(^OR(100,ORIFN,4.5,1,2,1,0)) I $E(X,1,3)=">> " S X=$E(X,4,999),^(0)=X
S $P(^OR(100,ORIFN,0),U,5)=+$O(^ORD(101.41,"AB","OR GXTEXT WORD PROCESSING ORDER",0))_";ORD(101.41,"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOR3C100 5800 printed Sep 23, 2025@20:02:56 Page 2
OR3C100 ; SLC/MKB - Orders file conversion for CPRS/OE3 ;8/8/97 15:27
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997
ORDERS(ORVP) ; -- Convert all orders for patient ORVP
+1 NEW ORPARAM,ORIDT,ORDG,ORIFN,OR0,OR3,OR6,ORSTRT,ORSTOP,ORSTS,DC,DC0,ORACT,ORCAT,RIFN,ORYD,ORNOW,ORDA,CURR,I
SET U="^"
+2 SET ORPARAM=$$GET^XPAR("SYS","ORPF ACTIVE ORDERS CONTEXT HRS",1,"Q")
ORD1 SET ORIDT=0
FOR
SET ORIDT=$ORDER(^OR(100,"AO",ORVP,ORIDT))
if ORIDT'>0
QUIT
SET ORDG=0
FOR
SET ORDG=$ORDER(^OR(100,"AO",ORVP,ORIDT,ORDG))
if ORDG'>0
QUIT
SET ORIFN=0
FOR
SET ORIFN=$ORDER(^OR(100,"AO",ORVP,ORIDT,ORDG,ORIFN))
if ORIFN'>0
QUIT
Begin DoDot:1
+1 SET OR0=$GET(^OR(100,ORIFN,0))
SET OR3=$GET(^(3))
SET OR6=$GET(^(6))
if '$LENGTH(OR0)
GOTO QQ
+2 ; bad record
IF 'ORVP!('$DATA(^DPT(+ORVP,0)))!('ORDG)!('$DATA(^ORD(100.98,+ORDG,0)))
DO CLEAN(ORIFN)
GOTO QQ
+3 IF $PIECE(OR0,U,5)["ORD(101,"
IF $PIECE($GET(^ORD(101,+$PIECE(OR0,U,5),0)),U)?1"ORGY ".E
SET $PIECE(^OR(100,ORIFN,3),U,8)=1
GOTO QQ
+4 SET ORSTRT=$PIECE(OR3,U,6)
SET ORSTOP=$PIECE(OR0,U,9)
SET ORSTS=$PIECE(OR3,U,3)
+5 ; look for DC order
KILL DC,DC0,ORACT,ORCAT
IF $DATA(^OR(100,ORIFN,8))
Begin DoDot:2
+6 SET RIFN=0
FOR
SET RIFN=$ORDER(^OR(100,ORIFN,8,RIFN))
if RIFN'>0
QUIT
IF $DATA(^OR(100,RIFN,0))
IF "^1^2^11^"[(U_$PIECE($GET(^(3)),U,3)_U)
IF $EXTRACT($GET(^(1,1,0)),1,2)="DC"
SET DC=RIFN
End DoDot:2
+7 SET ORYD=$$ORYD(ORPARAM)
SET ORNOW=$$NOW^XLFDT
NW ; encrypt ES
SET ORDA=1
SET ORACT(ORDA,0)=$PIECE(OR0,U,7)_"^NW^"_$PIECE(OR3,U,7)_U_$PIECE(OR3,U,13)_U_$PIECE(OR3,U,10)_U_$PIECE(OR3,U,12)_U_$PIECE(OR3,U,14)_"^^^^^"_$$NATURE($PIECE(OR0,U,12))_U_$PIECE(OR0,U,6)_U_U_$SELECT($PIECE(OR3,U,3)=11:11,1:"")_U_
$PIECE(OR6,U,8,9)
+1 SET ORACT("C","NW",ORDA)=""
SET CURR=1
DO ACT($PIECE(OR0,U,7),$PIECE(OR3,U,13))
+2 IF ORSTS
IF "^1^2^7^14^99^"'[(U_ORSTS_U)
DO AC($PIECE(OR0,U,7))
+3 IF ORYD
IF "^1^2^7^"[(U_ORSTS_U)
IF ORSTOP'<ORYD
DO AC($PIECE(OR0,U,7))
+4 IF $PIECE(OR6,U)'=""
SET ORACT(ORDA,3)=$$FLAG(ORIFN)
+5 ; build 4.5 nodes if unreleased
IF ORSTS=11
DO BUILD
GOTO SET
DC ; add DC action
IF $GET(DC)
Begin DoDot:2
+1 SET ORDA=ORDA+1
SET DC0=$$DCACTION(DC)
SET ORACT(ORDA,0)=DC0
+2 SET ORACT("C","DC",ORDA)=""
DO ACT($PIECE(DC0,U),$PIECE(DC0,U,4))
+3 IF $PIECE(DC0,U,15)=11
DO AC($PIECE(DC0,U))
+4 IF $PIECE(DC0,U,15)=13
IF ORYD
IF $PIECE(DC0,U)'<ORYD
DO AC($PIECE(DC0,U))
+5 IF $PIECE($GET(^OR(100,DC,6)),U)'=""
SET ORACT(ORDA,3)=$$FLAG(DC)
+6 ; delete DC order
KILL ^OR(100,"AW",ORVP,ORDG,$SELECT($PIECE($GET(^OR(100,DC,3)),U,6):$PIECE(^(3),U,6),1:9999999),DC),^OR(100,DC)
End DoDot:2
SET ; convert text orders
IF $PIECE(OR0,U,14)=+$ORDER(^DIC(9.4,"C","OR",0))
DO ORG
+1 SET $PIECE(OR0,U,8)=$PIECE(OR3,U,6)
SET $PIECE(OR0,U,12)=$SELECT($DATA(ORCAT):ORCAT,1:$$CLASS($PIECE(OR0,U,10)))
SET $PIECE(OR0,U,16,17)=$SELECT($PIECE(OR3,U,13)=3:0,1:2)_U
+2 ; reset pkg to OR, for HL7 msgs
IF $PIECE(OR0,U,14)=+$ORDER(^DIC(9.4,"C","GMRV",0))
SET I=+$ORDER(^DIC(9.4,"C","OR",0))
if I
SET $PIECE(OR0,U,14)=I
+3 SET $PIECE(OR3,U,7)=CURR
FOR I=5,6,10,12,13,14,15
SET $PIECE(OR3,U,I)=""
+4 ; Flag/DC, Related Orders, Notifications
KILL ^OR(100,ORIFN,6),^(8),^(9)
+5 if $PIECE(OR6,U,12)
SET I=$$NATURE($PIECE(OR6,U,11))
SET ^OR(100,ORIFN,6)=$SELECT(I:I,1:$PIECE($GET(DC0),U,12))_U_$PIECE(OR6,U,12,13)
+6 SET ^OR(100,ORIFN,0)=OR0
SET ^(3)=OR3
SET ^(8,0)="^100.008DA^"_ORDA_U_ORDA
MERGE ^OR(100,ORIFN,8)=ORACT
+7 IF $DATA(^OR(100,ORIFN,5))
MERGE ^OR(100,ORIFN,8,1,5)=^OR(100,ORIFN,5)
KILL ^OR(100,ORIFN,5)
+8 IF ORSTRT
IF ORSTRT>ORNOW
IF ORSTS=8
SET ^OR(100,"AD",ORSTRT,ORIFN)=""
+9 IF ORSTOP
IF "^1^2^7^12^13^"'[(U_ORSTS_U)
SET ^OR(100,"AE",ORSTOP,ORIFN)=""
QQ KILL ^OR(100,"AO",ORVP,ORIDT,ORDG,ORIFN)
End DoDot:1
+1 QUIT
+2 ;
DCACTION(IFN) ; -- Returns related DC order
+1 NEW OR0,OR3,OR6,X
SET OR0=$GET(^OR(100,IFN,0))
SET OR3=$GET(^(3))
SET OR6=$GET(^(6))
+2 SET X=$PIECE(OR0,U,7)_"^DC^"_$PIECE(OR3,U,7)_U_$PIECE(OR3,U,13)_U_$PIECE(OR3,U,10)_U_$PIECE(OR3,U,12)_U_$PIECE(OR3,U,14)_"^^^^^"_$$NATURE($PIECE(OR0,U,12))_U_$PIECE(OR0,U,6)_U_U_$SELECT($PIECE(OR3,U,3)=11:11,$PIECE(OR3,U,3)=1:13,1:"")_U_...
... $PIECE(OR6,U,8,9)
+3 QUIT X
+4 ;
FLAG(IFN) ; -- Returns fields for flag
+1 NEW OR6,X
SET OR6=$GET(^OR(100,IFN,6))
+2 SET X=$PIECE(OR6,U)_U_$PIECE(OR6,U,4)_U_$PIECE(OR6,U,2,3)_U_$PIECE(OR6,U,7)_U_$PIECE(OR6,U,5,6)
SET $PIECE(OR6,U,1,7)="^^^^^^"
+3 QUIT X
+4 ;
NATURE(X) ; -- Returns ptr to #100.02 for nature X
+1 NEW Y
SET Y=$SELECT(X="":"",1:$ORDER(^ORD(100.02,"C",X,0)))
+2 QUIT Y
+3 ;
AC(X) ; -- Set AC xref
+1 if X
SET ^OR(100,"AC",ORVP,9999999-X,ORIFN,ORDA)=""
+2 QUIT
+3 ;
ACT(X,SIG) ; -- ACT & AS xrefs
+1 if X
SET ^OR(100,"ACT",ORVP,9999999-X,ORDG,ORIFN,ORDA)=""
SET ^OR(100,"AF",X,ORIFN,ORDA)=""
+2 if $GET(SIG)=2
SET ^OR(100,"AS",ORVP,9999999-X,ORIFN,ORDA)=""
+3 QUIT
+4 ;
CLASS(LOC) ; -- Returns patient classification for order
+1 NEW X
SET X=$SELECT($DATA(ORCAT):ORCAT,1:"I")
+2 IF +LOC
IF $PIECE($GET(^SC(+LOC,0)),U,3)'="W"
SET X="O"
+3 QUIT X
+4 ;
ORYD(Y) ; -- Returns Current Orders context hours
+1 ; Y = ORPF ACTIVE ORDERS CONTEXT HRS parameter value
+2 NEW X,X1,X2,X3,%,%H
+3 IF Y
SET X=$HOROLOG
SET X=+X*24+($PIECE(X,",",2)/3600)
SET X2=Y
SET X1=X-X2
SET X3=X1#24
SET X1=X1\24
SET X2=$JUSTIFY(X3*3600,0,0)
SET %H=X1_","_X2
DO YMD^%DTC
SET Y=+(X_%)
+4 QUIT Y
+5 ;
CLEAN(DA) ; -- Clean up bad entries
+1 MERGE ^ORYX("ORDERS",DA)=^OR(100,DA)
+2 NEW DIK
SET DIK="^OR(100,"
DO ^DIK
+3 QUIT
+4 ;
BUILD ; -- Build Response multiple for unreleased orders
+1 NEW ORPK,ORPKG,ORDIALOG,ORQUIT
+2 SET ORPKG=$$NMSP^ORCD($PIECE(OR0,U,14))
if "PS"[ORPKG
QUIT
+3 SET ORPK=$GET(^OR(100,ORIFN,4))
KILL ^(4),^TMP("ORWORD",$JOB)
+4 ; build, save responses
DO ^OR3C100A
if $GET(ORQUIT)
QUIT
DO RESPONSE^ORCSAVE
+5 if $GET(ORDIALOG)
SET $PIECE(OR0,U,5)=+ORDIALOG_";ORD(101.41,"
+6 KILL ^TMP("ORWORD",$JOB)
+7 QUIT
+8 ;
ORG ; -- Convert generic orders from protocols to dialogs
+1 IF '$ORDER(^OR(100,ORIFN,4.5,0))
DO WP
QUIT
+2 NEW PITEM,DITEM,DA,PDA,PTR
SET PITEM=$PIECE(OR3,U,4)
+3 IF $SELECT('PITEM:1,PITEM'[";ORD(101,":1,'$DATA(^ORD(101,+PITEM,0)):1,1:0)
DO WP
QUIT
+4 SET DITEM=$$ITEM^ORCONVRT(+PITEM)
IF 'DITEM
DO WP
QUIT
+5 SET DA=0
FOR
SET DA=$ORDER(^OR(100,ORIFN,4.5,DA))
if DA'>0
QUIT
SET PDA=+$GET(^(DA,0))
Begin DoDot:1
+6 IF 'PDA
KILL ^OR(100,ORIFN,4.5,DA)
QUIT
+7 SET PTR=+$PIECE($GET(^ORD(101.41,DITEM,10,DA,0)),U,2)
+8 if PTR
SET ^OR(100,ORIFN,4.5,DA,0)=PDA_U_PTR_"^1"
End DoDot:1
+9 SET $PIECE(^OR(100,ORIFN,0),U,5)=DITEM_";ORD(101.41,"
+10 QUIT
+11 ;
WP ; -- Save as Word Processing dialog
+1 NEW WP
SET WP=+$ORDER(^ORD(101.41,"AB","OR GTX WORD PROCESSING 1",0))
+2 KILL ^OR(100,ORIFN,4.5)
SET ^(4.5,0)="^100.045A^1^1"
SET ^(1,0)="1^"_WP_"^1"
+3 MERGE ^OR(100,ORIFN,4.5,1,2)=^OR(100,ORIFN,1)
+4 NEW X
SET X=$GET(^OR(100,ORIFN,4.5,1,2,1,0))
IF $EXTRACT(X,1,3)=">> "
SET X=$EXTRACT(X,4,999)
SET ^(0)=X
+5 SET $PIECE(^OR(100,ORIFN,0),U,5)=+$ORDER(^ORD(101.41,"AB","OR GXTEXT WORD PROCESSING ORDER",0))_";ORD(101.41,"
+6 QUIT
