- 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 Feb 18, 2025@23:35:07 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