ORY315 ;SLC/JLC - POST INSTALL FOR OR 315 ;4/12/2011
;;3.0;ORDER ENTRY/RESULTS REPORTING;**315**;Dec 17,1997;Build 20
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;
Q
;
POST ;
;
N A,MCNT,DIC,X,Y,LPKG
K ^TMP($J,"ORY315")
S ^TMP($J,"ORY315",1,0)="Attempting to add the two new order reasons of Obsolete Order"
S ^TMP($J,"ORY315",2,0)="and purged order."
S ^TMP($J,"ORY315",3,0)=" "
S MCNT=3
S DIC=9.4,DIC(0)="BO",X="LAB SERVICE" D ^DIC
I Y=-1 S MCNT=MCNT+1,^TMP($J,"ORY315",MCNT,0)="Cannot determine the Lab package from file 9.4.",MCNT=MCNT+1,^TMP($J,"ORY315",MCNT,0)="Cannot add new reasons." D SEND Q
S LPKG=$P(Y,"^")
D CHECK("Obsolete Order",LPKG,.MCNT),CHECK("Purged Order",LPKG,.MCNT)
D SEND Q
CHECK(ORREASON,ALPKG,CNT) ;
N B,C,DIC,Y,ADD
S ADD=1,B=0 F S B=$O(^ORD(100.03,"B",ORREASON,B)) Q:'B D
. S C=$G(^ORD(100.03,B,0)) I C="" Q
. I $P(C,"^",5)=ALPKG D
.. S ADD=0,CNT=CNT+1,^TMP($J,"ORY315",CNT,0)=ORREASON_" is already on file for Lab"
.. I $P(C,"^",4)=1 S CNT=CNT+1,^TMP($J,"ORY315",CNT,0)="but currently inactive."
.. S CNT=CNT+1,^TMP($J,"ORY315",CNT,0)=" "
I ADD D ADD(ORREASON,ALPKG,.CNT)
Q
ADD(REASON,LP,ACNT) ;
N A,A1,A2,ORNAT,ORC,ORS
S ORNAT=$O(^ORD(100.02,"B","MAINTENANCE","")),ORC=$S(REASON["Obsolete":"LROBS",1:"LRPO"),ORS=$S(REASON["Obsolete":"LROBS",1:"POR")
F L +^ORD(100.03):$G(DILOCKTM,5) Q:$T H 5
S A=^ORD(100.03,0),A1=$P(A,"^",3)+1,A2=$P(A,"^",4)+1
S ^ORD(100.03,A1,0)=REASON_"^^"_ORS_"^^"_LP_"^"_ORC_"^"_ORNAT_"^14^"
S ^ORD(100.03,"B",REASON,A1)="",^ORD(100.03,"C",ORC,A1)=""
S ^ORD(100.03,"D",$$UP^XLFSTR(REASON),A1)="",^ORD(100.03,"S",ORS,A1)=""
S $P(^ORD(100.03,0),"^",3)=A1,$P(^(0),"^",4)=A2
S ACNT=ACNT+1,^TMP($J,"ORY315",ACNT,0)=REASON_" successfully added.",ACNT=ACNT+1,^TMP($J,"ORY315",ACNT,0)=" "
Q
SEND ;
Q:'$D(^TMP($J,"ORY315"))
N XMY,XMDUZ,XMSUB,XMTEXT
S XMDUZ="CPRS REASON,ADD",XMY("G.LRJ LSRP TRACKING")="",XMSUB="RESULTS OF ATTEMPT TO ADD NEW REASONS",XMTEXT="^TMP("_$J_",""ORY315"","
D ^XMD Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORY315 2050 printed Dec 13, 2024@02:41:09 Page 2
ORY315 ;SLC/JLC - POST INSTALL FOR OR 315 ;4/12/2011
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**315**;Dec 17,1997;Build 20
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;
+5 QUIT
+6 ;
POST ;
+1 ;
+2 NEW A,MCNT,DIC,X,Y,LPKG
+3 KILL ^TMP($JOB,"ORY315")
+4 SET ^TMP($JOB,"ORY315",1,0)="Attempting to add the two new order reasons of Obsolete Order"
+5 SET ^TMP($JOB,"ORY315",2,0)="and purged order."
+6 SET ^TMP($JOB,"ORY315",3,0)=" "
+7 SET MCNT=3
+8 SET DIC=9.4
SET DIC(0)="BO"
SET X="LAB SERVICE"
DO ^DIC
+9 IF Y=-1
SET MCNT=MCNT+1
SET ^TMP($JOB,"ORY315",MCNT,0)="Cannot determine the Lab package from file 9.4."
SET MCNT=MCNT+1
SET ^TMP($JOB,"ORY315",MCNT,0)="Cannot add new reasons."
DO SEND
QUIT
+10 SET LPKG=$PIECE(Y,"^")
+11 DO CHECK("Obsolete Order",LPKG,.MCNT)
DO CHECK("Purged Order",LPKG,.MCNT)
+12 DO SEND
QUIT
CHECK(ORREASON,ALPKG,CNT) ;
+1 NEW B,C,DIC,Y,ADD
+2 SET ADD=1
SET B=0
FOR
SET B=$ORDER(^ORD(100.03,"B",ORREASON,B))
if 'B
QUIT
Begin DoDot:1
+3 SET C=$GET(^ORD(100.03,B,0))
IF C=""
QUIT
+4 IF $PIECE(C,"^",5)=ALPKG
Begin DoDot:2
+5 SET ADD=0
SET CNT=CNT+1
SET ^TMP($JOB,"ORY315",CNT,0)=ORREASON_" is already on file for Lab"
+6 IF $PIECE(C,"^",4)=1
SET CNT=CNT+1
SET ^TMP($JOB,"ORY315",CNT,0)="but currently inactive."
+7 SET CNT=CNT+1
SET ^TMP($JOB,"ORY315",CNT,0)=" "
End DoDot:2
End DoDot:1
+8 IF ADD
DO ADD(ORREASON,ALPKG,.CNT)
+9 QUIT
ADD(REASON,LP,ACNT) ;
+1 NEW A,A1,A2,ORNAT,ORC,ORS
+2 SET ORNAT=$ORDER(^ORD(100.02,"B","MAINTENANCE",""))
SET ORC=$SELECT(REASON["Obsolete":"LROBS",1:"LRPO")
SET ORS=$SELECT(REASON["Obsolete":"LROBS",1:"POR")
+3 FOR
LOCK +^ORD(100.03):$GET(DILOCKTM,5)
if $TEST
QUIT
HANG 5
+4 SET A=^ORD(100.03,0)
SET A1=$PIECE(A,"^",3)+1
SET A2=$PIECE(A,"^",4)+1
+5 SET ^ORD(100.03,A1,0)=REASON_"^^"_ORS_"^^"_LP_"^"_ORC_"^"_ORNAT_"^14^"
+6 SET ^ORD(100.03,"B",REASON,A1)=""
SET ^ORD(100.03,"C",ORC,A1)=""
+7 SET ^ORD(100.03,"D",$$UP^XLFSTR(REASON),A1)=""
SET ^ORD(100.03,"S",ORS,A1)=""
+8 SET $PIECE(^ORD(100.03,0),"^",3)=A1
SET $PIECE(^(0),"^",4)=A2
+9 SET ACNT=ACNT+1
SET ^TMP($JOB,"ORY315",ACNT,0)=REASON_" successfully added."
SET ACNT=ACNT+1
SET ^TMP($JOB,"ORY315",ACNT,0)=" "
+10 QUIT
SEND ;
+1 if '$DATA(^TMP($JOB,"ORY315"))
QUIT
+2 NEW XMY,XMDUZ,XMSUB,XMTEXT
+3 SET XMDUZ="CPRS REASON,ADD"
SET XMY("G.LRJ LSRP TRACKING")=""
SET XMSUB="RESULTS OF ATTEMPT TO ADD NEW REASONS"
SET XMTEXT="^TMP("_$JOB_",""ORY315"","
+4 DO ^XMD
QUIT
