Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ORY242

ORY242.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1. PRE ; -- preinit
  1.  D NATURE
  1.  ;D REASON
  1.  Q
  1.  ;
  1. POST ; -- postinit
  1.  D VUID
  1.  Q
  1.  ;
  1. NATURE ; -- create new Nature of Order, verify standard values
  1.  N ORI,X,CODE,DA,X0,OR0,DR,DIE
  1.  ; enforce standard values
  1.  F ORI=1:1 S X=$T(ITEMS+ORI),CODE=$P(X,";",3) Q:CODE="ZZZZZ"  D
  1.  . S DA=+$O(^ORD(100.02,"C",CODE,0)) Q:DA<1
  1.  . I +$G(^ORD(100.02,DA,1))'=+$P(X,";",5) S $P(^(1),U)=+$P(X,";",5)
  1.  . I $P(^ORD(100.02,DA,1),U,4)'=$P(X,";",6) S $P(^(1),U,4)=$P(X,";",6)
  1.  . S X0=$P(X,";",4),OR0=$G(^ORD(100.02,DA,0))
  1.  . I OR0'=X0 S DR="" D  ;lock std values
  1.  .. F I=1:1:6 I $P(X0,U,I)'=$P(OR0,U,I) S DR=DR_".0"_I_"///"_$P(X0,U,I)_";"
  1.  .. I $L(DR) S DIE="^ORD(100.02," D ^DIE
  1.  ; add new SERVICE REJECT nature
  1.  S DA=+$O(^ORD(100.02,"B","SERVICE REJECT",0)) Q:DA  ;done
  1.  S DA=+$O(^ORD(100.02,"B","PHARMACY REJECT",0)) I 'DA D  ;use if exists,
  1.  . L +^ORD(100.02,0)                                     ;else get new DA
  1.  . S DA=11 F  S DA=DA+1 Q:'$D(^ORD(100.02,DA))
  1.  . S $P(^ORD(100.02,0),U,3,4)=DA_U_DA
  1.  . L -^ORD(100.02,0)
  1.  ; Kill old xrefs, if updating PHARMACY REJECT
  1.  S OR0=$G(^ORD(100.02,DA,0))
  1.  S X=$P(OR0,U) K:$L(X) ^ORD(100.02,"B",X,DA)
  1.  S X=$P(OR0,U,2) K:$L(X) ^ORD(100.02,"C",X,DA)
  1.  S X=$P(OR0,U,3) K:$L(X) ^ORD(100.02,"AC",X,DA)
  1.  ; Set new data
  1.  S ^ORD(100.02,DA,0)="SERVICE REJECT^R^0^^B^1",^(1)="1^1^0^2^^1"
  1.  S ^ORD(100.02,"AC",0,DA)=""
  1.  S ^ORD(100.02,"B","SERVICE REJECT",DA)=""
  1.  S ^ORD(100.02,"C","R",DA)=""
  1.  Q
  1.  ;
  1. ITEMS ;;CODE;0-node;CREATE ACTION;DEFAULT SIG STS
  1.  ;;W;WRITTEN^W^0^^X^0;1;0;
  1.  ;;V;VERBAL^V^0^^X^0;1;2;
  1.  ;;P;TELEPHONED^P^0^^X^0;1;2;
  1.  ;;S;SERVICE CORRECTION^S^0^^B^0;0;6;
  1.  ;;I;POLICY^I^0^^X^0;1;3;
  1.  ;;D;DUPLICATE^D^0^^X^1;0;;
  1.  ;;X;REJECTED^X^1^^B^1;0;;
  1.  ;;E;ELECTRONICALLY ENTERED^E^1^^F^0;1;2;
  1.  ;;A;AUTO^A^1^^X^0;0;;
  1.  ;;C;CHANGED^C^1^^X^1;0;;
  1.  ;;M;MAINTENANCE^M^1^^X^1;0;;
  1.  ;;R;SERVICE REJECT^R^0^^B^1;1;2;
  1.  ;;ZZZZZ;;;;
  1.  ;
  1. REASON ; -- restructure Reason file for standardization
  1.  ;   [save for later use]
  1.  N ORI,X,CODE,DA,DR,DIE,DIK,LRI,LRX
  1.  ; update reason NAMEs
  1.  F ORI=1:1 S X=$T(NAMES+ORI),CODE=$P(X,";",3) Q:CODE="ZZZZZ"  D
  1.  . S DA=+$O(^ORD(100.03,"C",CODE,0)) Q:DA<1
  1.  . Q:$P($G(^ORD(100.03,DA,0)),U)=$P(X,";",4)  ;done
  1.  . S DR=".01///"_$P(X,";",4),DIE="^ORD(100.03," D ^DIE
  1.  ; move PACKAGE and CODE fields of #100.03 into multiple
  1.  S LRI=+$O(^ORD(100.03,"C","LRPCAN",0)),LRX=$G(^ORD(100.03,LRI,0))
  1.  S ORI=0 F  S ORI=$O(^ORD(100.03,ORI)) Q:ORI<1  S X=$G(^(ORI,0)) D
  1.  . Q:$D(^ORD(100.03,ORI,1,0))  Q:'$P(X,U,5)  ;done, or no data
  1.  . I ORI=LRI S $P(^ORD(100.03,ORI,0),U,4)=1 Q  ;add to ORREQ instead
  1.  . S ^ORD(100.03,ORI,1,0)="^100.031P^1^1",^(1,0)=$P(X,U,5,6)
  1.  . S ^ORD(100.03,ORI,1,"B",+$P(X,U,5),1)=""
  1.  . S ^ORD(100.03,"APKG",+$P(X,U,5),ORI,1)=""
  1.  . S $P(^ORD(100.03,ORI,0),U,5,6)="^"
  1.  . I $L($P(X,U,6)) D  ;reset C xref
  1.  .. K ^ORD(100.03,"C",$P(X,U,6),ORI)
  1.  .. S ^ORD(100.03,"C",$P(X,U,6),ORI,1)=""
  1.  . I $P(X,U,6)="ORREQ",$P(LRX,U,5) D  ;add LRPCAN here
  1.  .. S ^ORD(100.03,ORI,1,0)="^100.031P^2^2",^(2,0)=$P(LRX,U,5,6)
  1.  .. S ^ORD(100.03,ORI,1,"B",+$P(LRX,U,5),2)=""
  1.  .. S ^ORD(100.03,"APKG",+$P(LRX,U,5),ORI,2)=""
  1.  .. S ^ORD(100.03,"C",$P(LRX,U,6),ORI,2)=""
  1.  .. K ^ORD(100.03,"C",$P(LRX,U,6),LRI)
  1.  .. S $P(^ORD(100.03,LRI,0),U,5,6)="^"
  1.  ; remove old PACKAGE and CODE fields, D xref
  1.  S DIK="^DD(100.03,",DA(1)=100.03 F DA=.05,.06 D ^DIK
  1.  K ^ORD(100.03,"D")
  1.  Q
  1.  ;
  1. NAMES ;;CODE;NAME of Reasons
  1.  ;;ORDUP;DUPLICATE ORDER
  1.  ;;ORDIS;DISCHARGE
  1.  ;;ORTRANS;TRANSFER
  1.  ;;ORSPEC;TREATING SPECIALTY CHANGE
  1.  ;;ORADMIT;ADMISSION
  1.  ;;ORREQ;PROVIDER CANCELLED
  1.  ;;OROBS;OBSOLETE ORDER
  1.  ;;ORERR;ENTERED IN ERROR
  1.  ;;ORDEATH;DEATH
  1.  ;;OROR;SURGERY
  1.  ;;ORPASS;PATIENT AWAY ON PASS
  1.  ;;ORASIH;ABSENT SICK IN HOSPITAL
  1.  ;;ZZZZZ;
  1.  ;
  1. VUID ; -- seed new VUID fields
  1.  N ORDOMPTR,TMP
  1.  S TMP=$$GETIEN^HDISVF09("ORDERS",.ORDOMPTR) ;IA#4651
  1.  I TMP D EN^HDISVCMR(ORDOMPTR,"") ;IA #4639
  1.  Q