ORMLR1 ; SLC/MKB - Process Lab ORM msgs cont ;3/20/97 08:22
;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997
XX ; -- add/delete tests
N OBR,ACTION,CNT,X,Y,I,J,OR0,ORDIALOG,ORDG,OREVENT,ORSTS,ORNP,OI,WP,SAMP,SPEC,TYPE,URG,SIGNED,NTE,LCNT,LAST,OLDIFN,PRMT,PARENT K ^TMP("ORWORD",$J)
S OBR=$O(@ORMSG@(+ORC)) I 'OBR S ORERR="Missing OBR segment" Q
S OBR=OBR_U_@ORMSG@(OBR),ACTION=$P(OBR,"|",12)
S X=$$ORDITEM^ORM($P(OBR,"|",5)) I 'X S ORERR="Invalid test" Q
S OR0=$G(^OR(100,+ORIFN,0)),ORNP=$P(OR0,U,4),ORDG=$P(OR0,U,11),ORSTS=5
S:'$G(ORL) ORL=$P(OR0,U,10),ORCAT=$P(OR0,U,12) ; no PV1
I ACTION=3 D Q:$D(ORERR) I CNT=1 D OC^ORMLR Q ; cancel if only test
. S (I,Y,CNT)=0
. F S I=$O(^OR(100,+ORIFN,.1,I)) Q:I'>0 S CNT=CNT+1 S:X=$G(^(I,0)) Y=1
. I 'Y S ORERR="Test not found" Q
S ORDIALOG=+$P(OR0,U,5) D GETDLG1^ORCD(ORDIALOG),GETORDER^ORCD(+ORIFN)
S OI=$$PTR("OR GTX ORDERABLE ITEM"),WP=$$PTR("OR GTX WORD PROCESSING 1")
S SAMP=$$PTR("OR GTX COLLECTION SAMPLE"),SPEC=$$PTR("OR GTX SPECIMEN")
S TYPE=$$PTR("OR GTX COLLECTION TYPE"),URG=$$PTR("OR GTX URGENCY")
XX1 I ACTION=3 S I=0 F S I=$O(ORDIALOG(OI,I)) Q:I'>0 I ORDIALOG(OI,I)=X F PRMT=OI,SAMP,SPEC,URG,TYPE,WP K ORDIALOG(PRMT,I)
I ACTION="A" D
. S LAST=$O(ORDIALOG(OI,"A"),-1),I=LAST+1
. S I=I+1,ORDIALOG(OI,I)=X,ORDIALOG(TYPE,I)=ORDIALOG(TYPE,LAST)
. S X=$$FIND^ORM(+OBR,16),ORDIALOG(SAMP,I)=$P(X,";",4)
. S X=$P(X,";") S:$L(X) ORDIALOG(SPEC,I)=+$O(^LAB(61,"C",X,0))
. S ORDIALOG(URG,I)=+$P($P($$FIND^ORM(+OBR,28),U,6),";",2)
. S NTE=$O(@ORMSG@(+OBR)) Q:'NTE Q:$E(@ORMSG@(NTE),1,3)'="NTE"
. S LCNT=1,^TMP("ORWORD",$J,WP,I,LCNT,0)=$P(@ORMSG@(NTE),"|",4)
. I $O(@ORMSG@(NTE,0)) S J=0 F S J=$O(@ORMSG@(NTE,J)) Q:J'>0 S LCNT=LCNT+1,^TMP("ORWORD",$J,WP,I,LCNT,0)=@ORMSG@(NTE,J)
. S ^TMP("ORWORD",$J,WP,I,0)="^^"_LCNT_U_LCNT_U_DT_U
. S ORDIALOG(WP,I)="^TMP(""ORWORD"",$J,"_WP_","_I_")"
XX2 S SIGNED=($P($G(^OR(100,+ORIFN,8,1,0)),U,4)'=2)
I SIGNED S OLDIFN=+ORIFN K ORIFN
D EN^ORCSAVE K ^TMP("ORWORD",$J)
I '$G(ORIFN) S ORERR="Cannot change order" Q
S ^OR(100,+ORIFN,4)=PKGIFN D:$P(^(8,1,0),U,4)=2 NOTIF^ORCSIGN
S ORNEW(ORIFN)="1^1" D PRINTS^ORWD1(.ORNEW,+$G(ORL)) ; print chart copy
I $G(OLDIFN) D ; clean-up old order
. S $P(^OR(100,+ORIFN,3),U,5)=OLDIFN D STATUS^ORCSAVE2(OLDIFN,12)
. S PARENT=$P(^OR(100,OLDIFN,3),U,9) I PARENT S $P(^OR(100,ORIFN,3),U,9)=PARENT K ^OR(100,PARENT,2,OLDIFN) S ^OR(100,PARENT,2,ORIFN,0)=ORIFN
. D RELEASE^ORCSAVE2(+ORIFN,,ORLOG,ORDUZ),MSG^ORMBLD(ORIFN,"NA")
Q
;
PTR(NAME) ; -- Returns ien of prompt NAME in Order Dialog file #101.41
Q $O(^ORD(101.41,"AB",$E(NAME,1,63),0))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORMLR1 2641 printed Apr 09, 2024@21:30:10 Page 2
ORMLR1 ; SLC/MKB - Process Lab ORM msgs cont ;3/20/97 08:22
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997
XX ; -- add/delete tests
+1 NEW OBR,ACTION,CNT,X,Y,I,J,OR0,ORDIALOG,ORDG,OREVENT,ORSTS,ORNP,OI,WP,SAMP,SPEC,TYPE,URG,SIGNED,NTE,LCNT,LAST,OLDIFN,PRMT,PARENT
KILL ^TMP("ORWORD",$JOB)
+2 SET OBR=$ORDER(@ORMSG@(+ORC))
IF 'OBR
SET ORERR="Missing OBR segment"
QUIT
+3 SET OBR=OBR_U_@ORMSG@(OBR)
SET ACTION=$PIECE(OBR,"|",12)
+4 SET X=$$ORDITEM^ORM($PIECE(OBR,"|",5))
IF 'X
SET ORERR="Invalid test"
QUIT
+5 SET OR0=$GET(^OR(100,+ORIFN,0))
SET ORNP=$PIECE(OR0,U,4)
SET ORDG=$PIECE(OR0,U,11)
SET ORSTS=5
+6 ; no PV1
if '$GET(ORL)
SET ORL=$PIECE(OR0,U,10)
SET ORCAT=$PIECE(OR0,U,12)
+7 ; cancel if only test
IF ACTION=3
Begin DoDot:1
+8 SET (I,Y,CNT)=0
+9 FOR
SET I=$ORDER(^OR(100,+ORIFN,.1,I))
if I'>0
QUIT
SET CNT=CNT+1
if X=$GET(^(I,0))
SET Y=1
+10 IF 'Y
SET ORERR="Test not found"
QUIT
End DoDot:1
if $DATA(ORERR)
QUIT
IF CNT=1
DO OC^ORMLR
QUIT
+11 SET ORDIALOG=+$PIECE(OR0,U,5)
DO GETDLG1^ORCD(ORDIALOG)
DO GETORDER^ORCD(+ORIFN)
+12 SET OI=$$PTR("OR GTX ORDERABLE ITEM")
SET WP=$$PTR("OR GTX WORD PROCESSING 1")
+13 SET SAMP=$$PTR("OR GTX COLLECTION SAMPLE")
SET SPEC=$$PTR("OR GTX SPECIMEN")
+14 SET TYPE=$$PTR("OR GTX COLLECTION TYPE")
SET URG=$$PTR("OR GTX URGENCY")
XX1 IF ACTION=3
SET I=0
FOR
SET I=$ORDER(ORDIALOG(OI,I))
if I'>0
QUIT
IF ORDIALOG(OI,I)=X
FOR PRMT=OI,SAMP,SPEC,URG,TYPE,WP
KILL ORDIALOG(PRMT,I)
+1 IF ACTION="A"
Begin DoDot:1
+2 SET LAST=$ORDER(ORDIALOG(OI,"A"),-1)
SET I=LAST+1
+3 SET I=I+1
SET ORDIALOG(OI,I)=X
SET ORDIALOG(TYPE,I)=ORDIALOG(TYPE,LAST)
+4 SET X=$$FIND^ORM(+OBR,16)
SET ORDIALOG(SAMP,I)=$PIECE(X,";",4)
+5 SET X=$PIECE(X,";")
if $LENGTH(X)
SET ORDIALOG(SPEC,I)=+$ORDER(^LAB(61,"C",X,0))
+6 SET ORDIALOG(URG,I)=+$PIECE($PIECE($$FIND^ORM(+OBR,28),U,6),";",2)
+7 SET NTE=$ORDER(@ORMSG@(+OBR))
if 'NTE
QUIT
if $EXTRACT(@ORMSG@(NTE),1,3)'="NTE"
QUIT
+8 SET LCNT=1
SET ^TMP("ORWORD",$JOB,WP,I,LCNT,0)=$PIECE(@ORMSG@(NTE),"|",4)
+9 IF $ORDER(@ORMSG@(NTE,0))
SET J=0
FOR
SET J=$ORDER(@ORMSG@(NTE,J))
if J'>0
QUIT
SET LCNT=LCNT+1
SET ^TMP("ORWORD",$JOB,WP,I,LCNT,0)=@ORMSG@(NTE,J)
+10 SET ^TMP("ORWORD",$JOB,WP,I,0)="^^"_LCNT_U_LCNT_U_DT_U
+11 SET ORDIALOG(WP,I)="^TMP(""ORWORD"",$J,"_WP_","_I_")"
End DoDot:1
XX2 SET SIGNED=($PIECE($GET(^OR(100,+ORIFN,8,1,0)),U,4)'=2)
+1 IF SIGNED
SET OLDIFN=+ORIFN
KILL ORIFN
+2 DO EN^ORCSAVE
KILL ^TMP("ORWORD",$JOB)
+3 IF '$GET(ORIFN)
SET ORERR="Cannot change order"
QUIT
+4 SET ^OR(100,+ORIFN,4)=PKGIFN
if $PIECE(^(8,1,0),U,4)=2
DO NOTIF^ORCSIGN
+5 ; print chart copy
SET ORNEW(ORIFN)="1^1"
DO PRINTS^ORWD1(.ORNEW,+$GET(ORL))
+6 ; clean-up old order
IF $GET(OLDIFN)
Begin DoDot:1
+7 SET $PIECE(^OR(100,+ORIFN,3),U,5)=OLDIFN
DO STATUS^ORCSAVE2(OLDIFN,12)
+8 SET PARENT=$PIECE(^OR(100,OLDIFN,3),U,9)
IF PARENT
SET $PIECE(^OR(100,ORIFN,3),U,9)=PARENT
KILL ^OR(100,PARENT,2,OLDIFN)
SET ^OR(100,PARENT,2,ORIFN,0)=ORIFN
+9 DO RELEASE^ORCSAVE2(+ORIFN,,ORLOG,ORDUZ)
DO MSG^ORMBLD(ORIFN,"NA")
End DoDot:1
+10 QUIT
+11 ;
PTR(NAME) ; -- Returns ien of prompt NAME in Order Dialog file #101.41
+1 QUIT $ORDER(^ORD(101.41,"AB",$EXTRACT(NAME,1,63),0))
