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

FHWOR1.m

Go to the documentation of this file.
  1. FHWOR1 ; HISC/REL/NCA - HL7 Additional Orders ;10/10/00 14:55
  1. ;;5.5;DIETETICS;;Jan 28, 2005
  1. ADD ; Add new Order
  1. S COM=$E(COM,1,160) D ORD^FHORO S $P(^FHPT(FHDFN,"A",ADM,"OO",FHDR,0),"^",8)=+FHORN
  1. S FILL="A"_";"_ADM_";"_FHDR_";"_COM K COM,FHDR
  1. D SEND^FHWOR Q
  1. CAN ; Process Cancel/Discontinue Order from OE/RR
  1. S FHDR=+$P(FILL,";",3) I 'FHDR S TXT="No Filler Number." D CERR^FHWOR Q
  1. D GADM^FHWORR
  1. F0 I '$D(^FHPT(FHDFN,"A",+ADM,"OO",+FHDR,0)) S TXT="Additional Order not on file." D CERR^FHWOR Q
  1. S Y=^FHPT(FHDFN,"A",ADM,"OO",FHDR,0)
  1. I +FHORN'=$P(Y,"^",8) S TXT="Order Number Not Matching." D CERR^FHWOR Q
  1. D NOW^%DTC S $P(^FHPT(FHDFN,"A",ADM,"OO",FHDR,0),"^",5,7)="X^"_%_"^"_DUZ
  1. K ^FHPT("AOO",FHDFN,ADM,FHDR) S EVT="O^C^"_FHDR D ^FHORX K %,FHDR,Y
  1. D CSEND^FHWOR Q
  1. AO ; Code Additional Orders
  1. K MSG S FILL="A"_";"_ADM_";"_FHDR_";"_COM
  1. S SDT=NOW D SET
  1. ; Code MSH, PID, and PV1
  1. D MSH^FHWOR
  1. ; code ORC
  1. S MSG(4)="ORC|SN||"_FILL_"^FH||||^^^"_SDT_"|||"_DUZ_"||"_DUZ_"|||"_NOW
  1. ; Code ODS
  1. S MSG(5)="ODS|D||^^^FH-6^Additional Order^99OTH|"_COM
  1. K FILL,FHWRD,HOSP,RM,SITE,SDT
  1. Q
  1. SET ; Set Date/Time in HL7 format
  1. S:SDT SDT=$$FMTHL7^XLFDT(SDT)
  1. S:NOW NOW=$$FMTHL7^XLFDT(NOW)
  1. Q
  1. NA ; OE/RR Number Assign
  1. S FHDR=+$P(FILL,";",3) G:'FHDR KIL S:ADM'=$P(FILL,";",2) ADM=$P(FILL,";",2)
  1. G:'+FHORN KIL
  1. S $P(^FHPT(FHDFN,"A",ADM,"OO",FHDR,0),"^",8)=+FHORN
  1. KIL K FHDR,MSG,FHORN Q