ORY242 ;SLC/MKB -- Support for patch OR*3*242 ;11/21/05 11:16
;;3.0;ORDER ENTRY/RESULTS REPORTING;**242**;Dec 17, 1997;Build 6
;
PRE ; -- preinit
D NATURE
;D REASON
Q
;
POST ; -- postinit
D VUID
Q
;
NATURE ; -- create new Nature of Order, verify standard values
N ORI,X,CODE,DA,X0,OR0,DR,DIE
; enforce standard values
F ORI=1:1 S X=$T(ITEMS+ORI),CODE=$P(X,";",3) Q:CODE="ZZZZZ" D
. S DA=+$O(^ORD(100.02,"C",CODE,0)) Q:DA<1
. I +$G(^ORD(100.02,DA,1))'=+$P(X,";",5) S $P(^(1),U)=+$P(X,";",5)
. I $P(^ORD(100.02,DA,1),U,4)'=$P(X,";",6) S $P(^(1),U,4)=$P(X,";",6)
. S X0=$P(X,";",4),OR0=$G(^ORD(100.02,DA,0))
. I OR0'=X0 S DR="" D ;lock std values
.. F I=1:1:6 I $P(X0,U,I)'=$P(OR0,U,I) S DR=DR_".0"_I_"///"_$P(X0,U,I)_";"
.. I $L(DR) S DIE="^ORD(100.02," D ^DIE
; add new SERVICE REJECT nature
S DA=+$O(^ORD(100.02,"B","SERVICE REJECT",0)) Q:DA ;done
S DA=+$O(^ORD(100.02,"B","PHARMACY REJECT",0)) I 'DA D ;use if exists,
. L +^ORD(100.02,0) ;else get new DA
. S DA=11 F S DA=DA+1 Q:'$D(^ORD(100.02,DA))
. S $P(^ORD(100.02,0),U,3,4)=DA_U_DA
. L -^ORD(100.02,0)
; Kill old xrefs, if updating PHARMACY REJECT
S OR0=$G(^ORD(100.02,DA,0))
S X=$P(OR0,U) K:$L(X) ^ORD(100.02,"B",X,DA)
S X=$P(OR0,U,2) K:$L(X) ^ORD(100.02,"C",X,DA)
S X=$P(OR0,U,3) K:$L(X) ^ORD(100.02,"AC",X,DA)
; Set new data
S ^ORD(100.02,DA,0)="SERVICE REJECT^R^0^^B^1",^(1)="1^1^0^2^^1"
S ^ORD(100.02,"AC",0,DA)=""
S ^ORD(100.02,"B","SERVICE REJECT",DA)=""
S ^ORD(100.02,"C","R",DA)=""
Q
;
ITEMS ;;CODE;0-node;CREATE ACTION;DEFAULT SIG STS
;;W;WRITTEN^W^0^^X^0;1;0;
;;V;VERBAL^V^0^^X^0;1;2;
;;P;TELEPHONED^P^0^^X^0;1;2;
;;S;SERVICE CORRECTION^S^0^^B^0;0;6;
;;I;POLICY^I^0^^X^0;1;3;
;;D;DUPLICATE^D^0^^X^1;0;;
;;X;REJECTED^X^1^^B^1;0;;
;;E;ELECTRONICALLY ENTERED^E^1^^F^0;1;2;
;;A;AUTO^A^1^^X^0;0;;
;;C;CHANGED^C^1^^X^1;0;;
;;M;MAINTENANCE^M^1^^X^1;0;;
;;R;SERVICE REJECT^R^0^^B^1;1;2;
;;ZZZZZ;;;;
;
REASON ; -- restructure Reason file for standardization
; [save for later use]
N ORI,X,CODE,DA,DR,DIE,DIK,LRI,LRX
; update reason NAMEs
F ORI=1:1 S X=$T(NAMES+ORI),CODE=$P(X,";",3) Q:CODE="ZZZZZ" D
. S DA=+$O(^ORD(100.03,"C",CODE,0)) Q:DA<1
. Q:$P($G(^ORD(100.03,DA,0)),U)=$P(X,";",4) ;done
. S DR=".01///"_$P(X,";",4),DIE="^ORD(100.03," D ^DIE
; move PACKAGE and CODE fields of #100.03 into multiple
S LRI=+$O(^ORD(100.03,"C","LRPCAN",0)),LRX=$G(^ORD(100.03,LRI,0))
S ORI=0 F S ORI=$O(^ORD(100.03,ORI)) Q:ORI<1 S X=$G(^(ORI,0)) D
. Q:$D(^ORD(100.03,ORI,1,0)) Q:'$P(X,U,5) ;done, or no data
. I ORI=LRI S $P(^ORD(100.03,ORI,0),U,4)=1 Q ;add to ORREQ instead
. S ^ORD(100.03,ORI,1,0)="^100.031P^1^1",^(1,0)=$P(X,U,5,6)
. S ^ORD(100.03,ORI,1,"B",+$P(X,U,5),1)=""
. S ^ORD(100.03,"APKG",+$P(X,U,5),ORI,1)=""
. S $P(^ORD(100.03,ORI,0),U,5,6)="^"
. I $L($P(X,U,6)) D ;reset C xref
.. K ^ORD(100.03,"C",$P(X,U,6),ORI)
.. S ^ORD(100.03,"C",$P(X,U,6),ORI,1)=""
. I $P(X,U,6)="ORREQ",$P(LRX,U,5) D ;add LRPCAN here
.. S ^ORD(100.03,ORI,1,0)="^100.031P^2^2",^(2,0)=$P(LRX,U,5,6)
.. S ^ORD(100.03,ORI,1,"B",+$P(LRX,U,5),2)=""
.. S ^ORD(100.03,"APKG",+$P(LRX,U,5),ORI,2)=""
.. S ^ORD(100.03,"C",$P(LRX,U,6),ORI,2)=""
.. K ^ORD(100.03,"C",$P(LRX,U,6),LRI)
.. S $P(^ORD(100.03,LRI,0),U,5,6)="^"
; remove old PACKAGE and CODE fields, D xref
S DIK="^DD(100.03,",DA(1)=100.03 F DA=.05,.06 D ^DIK
K ^ORD(100.03,"D")
Q
;
NAMES ;;CODE;NAME of Reasons
;;ORDUP;DUPLICATE ORDER
;;ORDIS;DISCHARGE
;;ORTRANS;TRANSFER
;;ORSPEC;TREATING SPECIALTY CHANGE
;;ORADMIT;ADMISSION
;;ORREQ;PROVIDER CANCELLED
;;OROBS;OBSOLETE ORDER
;;ORERR;ENTERED IN ERROR
;;ORDEATH;DEATH
;;OROR;SURGERY
;;ORPASS;PATIENT AWAY ON PASS
;;ORASIH;ABSENT SICK IN HOSPITAL
;;ZZZZZ;
;
VUID ; -- seed new VUID fields
N ORDOMPTR,TMP
S TMP=$$GETIEN^HDISVF09("ORDERS",.ORDOMPTR) ;IA#4651
I TMP D EN^HDISVCMR(ORDOMPTR,"") ;IA #4639
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORY242 3994 printed Apr 09, 2024@21:25:24 Page 2
ORY242 ;SLC/MKB -- Support for patch OR*3*242 ;11/21/05 11:16
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**242**;Dec 17, 1997;Build 6
+2 ;
PRE ; -- preinit
+1 DO NATURE
+2 ;D REASON
+3 QUIT
+4 ;
POST ; -- postinit
+1 DO VUID
+2 QUIT
+3 ;
NATURE ; -- create new Nature of Order, verify standard values
+1 NEW ORI,X,CODE,DA,X0,OR0,DR,DIE
+2 ; enforce standard values
+3 FOR ORI=1:1
SET X=$TEXT(ITEMS+ORI)
SET CODE=$PIECE(X,";",3)
if CODE="ZZZZZ"
QUIT
Begin DoDot:1
+4 SET DA=+$ORDER(^ORD(100.02,"C",CODE,0))
if DA<1
QUIT
+5 IF +$GET(^ORD(100.02,DA,1))'=+$PIECE(X,";",5)
SET $PIECE(^(1),U)=+$PIECE(X,";",5)
+6 IF $PIECE(^ORD(100.02,DA,1),U,4)'=$PIECE(X,";",6)
SET $PIECE(^(1),U,4)=$PIECE(X,";",6)
+7 SET X0=$PIECE(X,";",4)
SET OR0=$GET(^ORD(100.02,DA,0))
+8 ;lock std values
IF OR0'=X0
SET DR=""
Begin DoDot:2
+9 FOR I=1:1:6
IF $PIECE(X0,U,I)'=$PIECE(OR0,U,I)
SET DR=DR_".0"_I_"///"_$PIECE(X0,U,I)_";"
+10 IF $LENGTH(DR)
SET DIE="^ORD(100.02,"
DO ^DIE
End DoDot:2
End DoDot:1
+11 ; add new SERVICE REJECT nature
+12 ;done
SET DA=+$ORDER(^ORD(100.02,"B","SERVICE REJECT",0))
if DA
QUIT
+13 ;use if exists,
SET DA=+$ORDER(^ORD(100.02,"B","PHARMACY REJECT",0))
IF 'DA
Begin DoDot:1
+14 ;else get new DA
LOCK +^ORD(100.02,0)
+15 SET DA=11
FOR
SET DA=DA+1
if '$DATA(^ORD(100.02,DA))
QUIT
+16 SET $PIECE(^ORD(100.02,0),U,3,4)=DA_U_DA
+17 LOCK -^ORD(100.02,0)
End DoDot:1
+18 ; Kill old xrefs, if updating PHARMACY REJECT
+19 SET OR0=$GET(^ORD(100.02,DA,0))
+20 SET X=$PIECE(OR0,U)
if $LENGTH(X)
KILL ^ORD(100.02,"B",X,DA)
+21 SET X=$PIECE(OR0,U,2)
if $LENGTH(X)
KILL ^ORD(100.02,"C",X,DA)
+22 SET X=$PIECE(OR0,U,3)
if $LENGTH(X)
KILL ^ORD(100.02,"AC",X,DA)
+23 ; Set new data
+24 SET ^ORD(100.02,DA,0)="SERVICE REJECT^R^0^^B^1"
SET ^(1)="1^1^0^2^^1"
+25 SET ^ORD(100.02,"AC",0,DA)=""
+26 SET ^ORD(100.02,"B","SERVICE REJECT",DA)=""
+27 SET ^ORD(100.02,"C","R",DA)=""
+28 QUIT
+29 ;
ITEMS ;;CODE;0-node;CREATE ACTION;DEFAULT SIG STS
+1 ;;W;WRITTEN^W^0^^X^0;1;0;
+2 ;;V;VERBAL^V^0^^X^0;1;2;
+3 ;;P;TELEPHONED^P^0^^X^0;1;2;
+4 ;;S;SERVICE CORRECTION^S^0^^B^0;0;6;
+5 ;;I;POLICY^I^0^^X^0;1;3;
+6 ;;D;DUPLICATE^D^0^^X^1;0;;
+7 ;;X;REJECTED^X^1^^B^1;0;;
+8 ;;E;ELECTRONICALLY ENTERED^E^1^^F^0;1;2;
+9 ;;A;AUTO^A^1^^X^0;0;;
+10 ;;C;CHANGED^C^1^^X^1;0;;
+11 ;;M;MAINTENANCE^M^1^^X^1;0;;
+12 ;;R;SERVICE REJECT^R^0^^B^1;1;2;
+13 ;;ZZZZZ;;;;
+14 ;
REASON ; -- restructure Reason file for standardization
+1 ; [save for later use]
+2 NEW ORI,X,CODE,DA,DR,DIE,DIK,LRI,LRX
+3 ; update reason NAMEs
+4 FOR ORI=1:1
SET X=$TEXT(NAMES+ORI)
SET CODE=$PIECE(X,";",3)
if CODE="ZZZZZ"
QUIT
Begin DoDot:1
+5 SET DA=+$ORDER(^ORD(100.03,"C",CODE,0))
if DA<1
QUIT
+6 ;done
if $PIECE($GET(^ORD(100.03,DA,0)),U)=$PIECE(X,";",4)
QUIT
+7 SET DR=".01///"_$PIECE(X,";",4)
SET DIE="^ORD(100.03,"
DO ^DIE
End DoDot:1
+8 ; move PACKAGE and CODE fields of #100.03 into multiple
+9 SET LRI=+$ORDER(^ORD(100.03,"C","LRPCAN",0))
SET LRX=$GET(^ORD(100.03,LRI,0))
+10 SET ORI=0
FOR
SET ORI=$ORDER(^ORD(100.03,ORI))
if ORI<1
QUIT
SET X=$GET(^(ORI,0))
Begin DoDot:1
+11 ;done, or no data
if $DATA(^ORD(100.03,ORI,1,0))
QUIT
if '$PIECE(X,U,5)
QUIT
+12 ;add to ORREQ instead
IF ORI=LRI
SET $PIECE(^ORD(100.03,ORI,0),U,4)=1
QUIT
+13 SET ^ORD(100.03,ORI,1,0)="^100.031P^1^1"
SET ^(1,0)=$PIECE(X,U,5,6)
+14 SET ^ORD(100.03,ORI,1,"B",+$PIECE(X,U,5),1)=""
+15 SET ^ORD(100.03,"APKG",+$PIECE(X,U,5),ORI,1)=""
+16 SET $PIECE(^ORD(100.03,ORI,0),U,5,6)="^"
+17 ;reset C xref
IF $LENGTH($PIECE(X,U,6))
Begin DoDot:2
+18 KILL ^ORD(100.03,"C",$PIECE(X,U,6),ORI)
+19 SET ^ORD(100.03,"C",$PIECE(X,U,6),ORI,1)=""
End DoDot:2
+20 ;add LRPCAN here
IF $PIECE(X,U,6)="ORREQ"
IF $PIECE(LRX,U,5)
Begin DoDot:2
+21 SET ^ORD(100.03,ORI,1,0)="^100.031P^2^2"
SET ^(2,0)=$PIECE(LRX,U,5,6)
+22 SET ^ORD(100.03,ORI,1,"B",+$PIECE(LRX,U,5),2)=""
+23 SET ^ORD(100.03,"APKG",+$PIECE(LRX,U,5),ORI,2)=""
+24 SET ^ORD(100.03,"C",$PIECE(LRX,U,6),ORI,2)=""
+25 KILL ^ORD(100.03,"C",$PIECE(LRX,U,6),LRI)
+26 SET $PIECE(^ORD(100.03,LRI,0),U,5,6)="^"
End DoDot:2
End DoDot:1
+27 ; remove old PACKAGE and CODE fields, D xref
+28 SET DIK="^DD(100.03,"
SET DA(1)=100.03
FOR DA=.05,.06
DO ^DIK
+29 KILL ^ORD(100.03,"D")
+30 QUIT
+31 ;
NAMES ;;CODE;NAME of Reasons
+1 ;;ORDUP;DUPLICATE ORDER
+2 ;;ORDIS;DISCHARGE
+3 ;;ORTRANS;TRANSFER
+4 ;;ORSPEC;TREATING SPECIALTY CHANGE
+5 ;;ORADMIT;ADMISSION
+6 ;;ORREQ;PROVIDER CANCELLED
+7 ;;OROBS;OBSOLETE ORDER
+8 ;;ORERR;ENTERED IN ERROR
+9 ;;ORDEATH;DEATH
+10 ;;OROR;SURGERY
+11 ;;ORPASS;PATIENT AWAY ON PASS
+12 ;;ORASIH;ABSENT SICK IN HOSPITAL
+13 ;;ZZZZZ;
+14 ;
VUID ; -- seed new VUID fields
+1 NEW ORDOMPTR,TMP
+2 ;IA#4651
SET TMP=$$GETIEN^HDISVF09("ORDERS",.ORDOMPTR)
+3 ;IA #4639
IF TMP
DO EN^HDISVCMR(ORDOMPTR,"")
+4 QUIT
