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

PSJPDCLV.m

Go to the documentation of this file.
  1. PSJPDCLV ;PER/ME - PADE ORDER ; 11/18/19 1:17pm
  1. ;;5.0;INPATIENT MEDICATIONS;**405,364,420**;16 DEC 97;Build 2
  1. Q
  1. ;PSJ*5*405 routine PSJPDCLU became to large (SACC max limit) and had to be split into routine PSJPDCLV
  1. ;*364 - Moving CORD and SEND tags from PSJPDCLU due to SACC max limit
  1. ;
  1. DOWSTR(SCHED) ; Return 7-digit binary representation for the Day-Of-Week Schedule
  1. ; Input: SCHED - Schedule (e.g., "ONCE", "AC-PRN", "MO-WE-FR", "TH", etc)
  1. ;Output: DOWSTR - 7-digit binary representation for Day-of-Week Schedules (e.g., SU = 1000000, SU-TU-TH-SA = 1010101, etc.)
  1. N DOWSCH,DOWSTR,DOW,I
  1. S DOWSCH=1,SCHED=$P(SCHED,"@"),DOWSTR="00000000"
  1. F I=1:1:$L(SCHED,"-") D I 'DOWSCH Q
  1. . S DOW=$P(SCHED,"-",I)
  1. . I '$F("-SU-MO-TU-WE-TH-FR-SA-","-"_DOW_"-") S DOWSCH=0 Q
  1. . S $E(DOWSTR,$S(DOW="SU":1,DOW="MO":2,DOW="TU":3,DOW="WE":4,DOW="TH":5,DOW="FR":6,DOW="SA":7))=1
  1. Q $S('DOWSCH:"00000000",1:DOWSTR)
  1. ;
  1. CORD ;*364
  1. Q:'PSJQ
  1. N ST0,PS55,PDL S (SEQ,ST0)=0
  1. S PS55=$S(RXO["U":"^PS(55,DFN,5,+RXO)",1:"^PS(55,DFN,""IV"",+RXO)")
  1. N PSJORDER S PSJORDER=PS55,$E(PSJORDER,*)="," ;*364
  1. Q:PS55=""
  1. M PS55=@PS55
  1. I RXO["U" Q:'$P($G(PS55(2)),"^",2)!('$P($G(PS55(2)),"^",4))
  1. I RXO["V" Q:'$G(PS55(.2))!('$P($G(PS55(0)),"^",2))
  1. N VAR1,VAR2,STATUS,PDDT,PDHDT
  1. S PDDT=$$NOW^XLFDT(),PDHDT=+$$HLDATE^HLFNC(PDDT,"TS")
  1. D PID^PSJPDCLU,PV1^PSJPDCLU,AGY^PSJPDCL,ORC^PSJPDCLU,RXE^PSJPDCLU,RXR^PSJPDCLU
  1. D:RXO["V" IVRXC^PSJPDCLU
  1. I RXO["U" N CNT S CNT=0 D D:CNT>1 RXC^PSJPDCLU ; IF THERE ARE > 1 ACTIVE DD, MAKE AN RXC FOR EACH
  1. . N X1 S X1=0 F S X1=$O(PS55(1,X1)) Q:'X1 D
  1. .. I $P(PS55(1,X1,0),"^",3),$P(PS55(1,X1,0),"^",3)'>DT Q ; DONT COUNT IF IT HAS AN INNACTIVATION DATE (PAST)
  1. .. S CNT=CNT+1
  1. D ZRX^PSJPDCLU
  1. N ZTIO,ZTRTN,ZTSAVE,ZTDESC,ZTDTH
  1. S ZTIO=""
  1. S:CLAPDT PDL(16)=CLAPDT
  1. S ZTRTN="SEND^PSJPDCLV"
  1. F XX="NSEG(","PSJQ(","PSJQ2(","SETZ","HLFS","HLECH","HL(","SNM","CNM","PDL(","FTS","ASIH","PSJDCA","PSJORDER","DFN","RXO" S ZTSAVE(XX)="" ;*364
  1. S ZTDESC="PADE HL7 Order Message Router"
  1. S ZTDTH=$H
  1. D ^%ZTLOAD
  1. Q
  1. ;
  1. SEND ;*364
  1. N XX,PSJND,PSJVNM,PSJDNS,PSJVP,VR,HLA,NHL,CT,PDLTMP,HAZ,HAZH,HAZD
  1. M PDLTMP=PDL ; Preserve PDL array info
  1. M NHL=HL
  1. S XX=0,CT=$O(NSEG(9999),-1)+1
  1. F S XX=$O(PSJQ(XX)) Q:'XX D
  1. .M PDL=PDLTMP ; Restore PDL array after cleaned up by LOG^PSJPADE
  1. .M HL=NHL
  1. .S PSJND=$G(^PS(58.7,XX,0))
  1. .Q:PSJND=""
  1. .S PSJVNM=$P(PSJND,"^"),PSJDNS=$P(PSJND,"^",2),PSJVP=$P(PSJND,"^",3)
  1. .Q:PSJVNM=""!(PSJDNS="")!('PSJVP)
  1. .N HLP,PSJSND
  1. .S HLP("SUBSCRIBER")="^^^^~"_PSJDNS_":"_PSJVP_"~DNS"
  1. .N ZZ1,ZZ2 S (ZZ1,ZZ2)=""
  1. .I SETZ="C" S ZZ2=$P($G(PSJQ2(XX)),"^",2)
  1. .I SETZ="IC" S ZZ1=$P($G(PSJQ2(XX)),"^",2),ZZ2=$P($G(PSJQ(XX)),"^",2)
  1. .I SETZ="I" S ZZ1=$P($G(PSJQ(XX)),"^",2)
  1. .S HAZ=$$HAZDRUG^PSJHLU(PSJORDER) ;PSJORDER prev saved by JOBQ *364
  1. .S HAZH=$S($P(HAZ,U):"Y",1:"N"),HAZD=$S($P(HAZ,U,2):"Y",1:"N")
  1. .S NSEG(CT)="ZZZ"_HL("FS")_ZZ1_HL("FS")_ZZ2_HL("FS")_FTS_HL("FS")_HAZH_HL("FS")_HAZD
  1. .D PV19^PSJPDAPP
  1. .K HLA M HLA("HLS")=NSEG
  1. .D GENERATE^HLMA(SNM,"LM",1,.PSJSND,"",.HLP)
  1. .D LOG^PSJPADE
  1. Q