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