- 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 Feb 18, 2025@23:58:34 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))
