ORY7 ;SLB/MKB-postinit for OR*3.0*7 ;3/20/98 14:45
;;3.0;ORDER ENTRY/RESULTS REPORTING;**7**;Dec 17, 1997
;
POST ; -- Set ^ORD(100.03,"D"), value for Lab parameter
;
N DIK,ORX
I '$D(^ORD(100.03,"D")) S DIK="^ORD(100.03,",DIK(1)=".01^D" D ENALL^DIK
S ORX=$P($G(^ORD(100.99,1,0)),U,18)
D:$L(ORX) EN^XPAR("SYS","ORPF SHOW LAB #",1,ORX)
Q
;
PRE ; -- preinit cleanup of Order Reason file #100.03
N DA,DIK,ORSYN,ORNM,ORI,ORACTV,ORINACT,ORX
S DA=.001,DA(1)=100.03,DIK="^DD(100.03," D ^DIK ;remove NUMBER field
F ORSYN="DUP","ER" D ;cleanup duplicates
. K ORACTV,ORINACT S ORI=0
. F S ORI=$O(^ORD(100.03,"S",ORSYN,ORI)) Q:ORI'>0 D
.. S ORX=$G(^ORD(100.03,+ORI,0))
.. I $P(ORX,U,4) S ORINACT=+$G(ORINACT)+1,ORINACT(+ORI)=ORX
.. E S ORACTV=+$G(ORACTV)+1,ORACTV(+ORI)=ORX
. S ORNM=$S(ORSYN="DUP":"Duplicate Order",1:"Entered in error")
. I $G(ORINACT) S ORI=0 F S ORI=$O(ORINACT(ORI)) Q:ORI'>0 S ORX=ORINACT(ORI) D INACT
. S ORI=$O(ORACTV(0)) Q:ORI'>0 S ORX=ORACTV(ORI)
. I ORSYN="DUP",ORNM'=$P(ORX,U) D SETNM(ORI,ORNM)
. I ORSYN="ER",'$P(ORX,U,7) S $P(^ORD(100.03,ORI,0),U,7)=+$O(^ORD(100.02,"C","M",0)) ;set nature="maintenance"
. I $G(ORACTV)>1 F S ORI=$O(ORACTV(ORI)) Q:ORI'>0 S ORX=ORACTV(ORI) D INACT ;inactivate extra entries
Q
;
INACT ; -- inactivate reason
N DA,DR,DIE,X,Y
S DA=ORI,DIE="^ORD(100.03,",DR=".03///@;.04////1;.06///@"
S:ORNM=$P(ORX,U) DR=".01///Z"_ORNM_";"_DR D ^DIE
Q
;
SETNM(DA,X) ; -- set .01 Name
N DR,DIE,Y Q:'DA
S DIE="^ORD(100.03,",DR=".01///"_X D ^DIE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORY7 1554 printed Apr 09, 2024@21:25 Page 2
ORY7 ;SLB/MKB-postinit for OR*3.0*7 ;3/20/98 14:45
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7**;Dec 17, 1997
+2 ;
POST ; -- Set ^ORD(100.03,"D"), value for Lab parameter
+1 ;
+2 NEW DIK,ORX
+3 IF '$DATA(^ORD(100.03,"D"))
SET DIK="^ORD(100.03,"
SET DIK(1)=".01^D"
DO ENALL^DIK
+4 SET ORX=$PIECE($GET(^ORD(100.99,1,0)),U,18)
+5 if $LENGTH(ORX)
DO EN^XPAR("SYS","ORPF SHOW LAB #",1,ORX)
+6 QUIT
+7 ;
PRE ; -- preinit cleanup of Order Reason file #100.03
+1 NEW DA,DIK,ORSYN,ORNM,ORI,ORACTV,ORINACT,ORX
+2 ;remove NUMBER field
SET DA=.001
SET DA(1)=100.03
SET DIK="^DD(100.03,"
DO ^DIK
+3 ;cleanup duplicates
FOR ORSYN="DUP","ER"
Begin DoDot:1
+4 KILL ORACTV,ORINACT
SET ORI=0
+5 FOR
SET ORI=$ORDER(^ORD(100.03,"S",ORSYN,ORI))
if ORI'>0
QUIT
Begin DoDot:2
+6 SET ORX=$GET(^ORD(100.03,+ORI,0))
+7 IF $PIECE(ORX,U,4)
SET ORINACT=+$GET(ORINACT)+1
SET ORINACT(+ORI)=ORX
+8 IF '$TEST
SET ORACTV=+$GET(ORACTV)+1
SET ORACTV(+ORI)=ORX
End DoDot:2
+9 SET ORNM=$SELECT(ORSYN="DUP":"Duplicate Order",1:"Entered in error")
+10 IF $GET(ORINACT)
SET ORI=0
FOR
SET ORI=$ORDER(ORINACT(ORI))
if ORI'>0
QUIT
SET ORX=ORINACT(ORI)
DO INACT
+11 SET ORI=$ORDER(ORACTV(0))
if ORI'>0
QUIT
SET ORX=ORACTV(ORI)
+12 IF ORSYN="DUP"
IF ORNM'=$PIECE(ORX,U)
DO SETNM(ORI,ORNM)
+13 ;set nature="maintenance"
IF ORSYN="ER"
IF '$PIECE(ORX,U,7)
SET $PIECE(^ORD(100.03,ORI,0),U,7)=+$ORDER(^ORD(100.02,"C","M",0))
+14 ;inactivate extra entries
IF $GET(ORACTV)>1
FOR
SET ORI=$ORDER(ORACTV(ORI))
if ORI'>0
QUIT
SET ORX=ORACTV(ORI)
DO INACT
End DoDot:1
+15 QUIT
+16 ;
INACT ; -- inactivate reason
+1 NEW DA,DR,DIE,X,Y
+2 SET DA=ORI
SET DIE="^ORD(100.03,"
SET DR=".03///@;.04////1;.06///@"
+3 if ORNM=$PIECE(ORX,U)
SET DR=".01///Z"_ORNM_";"_DR
DO ^DIE
+4 QUIT
+5 ;
SETNM(DA,X) ; -- set .01 Name
+1 NEW DR,DIE,Y
if 'DA
QUIT
+2 SET DIE="^ORD(100.03,"
SET DR=".01///"_X
DO ^DIE
+3 QUIT
