- PSOHLINC ;BIR/RTR - Process incoming order messages from CHCS ;06/17/02
- ;;7.0;OUTPATIENT PHARMACY;**111,143**;DEC 1997
- ;
- EN ;Process incoming outpatient order messages
- N PSOXLONG,PSOHDFOR,PSOHLTAG,PSOHBDS,PSOHMSG,PSOHLMIS,PSOHLRS,PSOHEID,PSOHEIDS,PSOHFSP,PSOHLNOP,PSOXHI,PSOHLZ,PSOHLZC,PSOHLRXO,PSOXMH,PSOHY,PSOEXMS,PSOEXXQ,PSOHG,PSOBH,X,Y
- I '$G(DT) S DT=$$DT^XLFDT
- S (PSOXLONG,PSOHLRXO,PSOHLNOP,PSOHDFOR)=0
- S PSOHFSP=$E(HL("ECH"),1)
- K PSOHLMIS
- F PSOXHI=1:1 K PSOHB X HLNEXT Q:HLQUIT'>0!(PSOHLNOP)!(PSOHDFOR)!(PSOXLONG) S PSOHB=HLNODE,PSOXMH=$E(PSOHB,1,3) D
- .S PSOHG=0 F S PSOHG=$O(HLNODE(PSOHG)) Q:'PSOHG!(PSOHLNOP)!(PSOHDFOR)!(PSOXLONG) S PSOHB(PSOHG)=HLNODE(PSOHG)
- .I (PSOXMH'?3U),(PSOXMH'?2U1N) S PSOHDFOR=1 Q
- .I $T(@PSOXMH)]"" D @PSOXMH
- ;Quit if not a Pharmacy message, no acknowledgements
- I $G(PSOHLNOP) Q
- I $G(PSOHY("OCC"))="CA" D ENDC^PSOHLDC Q
- I PSOXLONG S PSOEXMS="Invalid NTE segment, greater than 245 characters." D NAK^PSOHLEXC Q
- S (PSOHBDS,PSOEXXQ)=0
- I PSOHDFOR S PSOEXMS="Invalid message structure." D NAK^PSOHLEXC Q
- F PSOHMSG="MSH","PID","PV1","ORC","RXO" Q:PSOEXXQ I '$D(PSOHLMIS(PSOHMSG)) S PSOEXMS="Missing "_PSOHMSG_" segment." S PSOHBDS=1 D NAK^PSOHLEXC
- ;Quit if segment is missing
- I $G(PSOEXXQ) Q
- ;Quit if not a Pharmacy message, no acknowledgements
- ;I $G(PSOHLNOP) Q
- ;check for data exceptions
- D CHECK^PSOHLEXC
- ;PSOEXXQ set if a NAK was sent back
- I $G(PSOEXXQ) Q
- ;Enter order into Pending Outpatient Orders file
- D ADD^PSOHCPRS
- ;Send successful acknowledgement if PSOEXXQ not set
- I '$G(PSOEXXQ) D ACK^PSOHLEXC
- Q
- ;What about regular acknowledgements? handled by HL7 package somehow
- Q
- MSH ;Process MSH segment
- I $P(PSOHB,HL("FS"),5)'="PSO RECEIVE" S PSOHLNOP=1
- S PSOHLMIS("MSH")=""
- Q
- PID ;Process PID segment
- D FORM
- S PSOHY("PAT")=+$P(PSOHB,HL("FS"),3)
- S PSOHLMIS("PID")=""
- Q
- PV1 ;Process PV1 segment
- D FORM
- S PSOHY("LOC")=+$P(PSOHB,HL("FS"),3)
- S PSOHLMIS("PV1")=""
- Q
- DG1 ;Process DG1 segment ; future use
- D FORM
- S $P(PSOHY("ICD"),U,$P(PSOHB,HL("FS"),1))=$P(PSOHB,HL("FS"),3)
- ZCL Q ;future use
- ;
- ORC ;Process ORC segment
- S PSOHLRXO=1 ;For future use in processing NTE's, if other segments get NTE(6) or (7)
- D FORM
- I $O(PSOHB(""))'="" D ORC^PSOHLINL Q
- S PSOHY("OCC")=$P(PSOHB,HL("FS"))
- ;Set priority to Routine
- S PSOHY("PRIOR")="R"
- S PSOHY("CHNUM")=$P($P(PSOHB,HL("FS"),2),PSOHFSP)
- D NOW^%DTC S PSOHY("EDT")=%
- S X=$P(PSOHB,HL("FS"),9) D
- .I X S PSOHY("SDT")=$$HL7TFM^XLFDT(X) Q
- .S PSOHY("SDT")=$G(PSOHY("EDT"))
- S PSOHY("ENTER")=+$P(PSOHB,HL("FS"),10)
- S PSOHY("PROV")=+$P(PSOHB,HL("FS"),12)
- S PSOHLMIS("ORC")=""
- Q
- RXO ;Process RXO segment
- D FORM
- I $O(PSOHB(""))'="" D RXO^PSOHLINL Q
- S PSOHY("DRUG")=+$P(PSOHB,HL("FS"),10)
- S PSOHY("QTY")=$P(PSOHB,HL("FS"),11)
- S PSOHY("REF")=$P(PSOHB,HL("FS"),13)
- S PSOHLMIS("RXO")=""
- Q
- RXR ;Process RXR segment
- D FORM
- Q
- ZRX ;Process ZRX segment
- D FORM
- S PSOHY("PICK")=$S($P(PSOHB,HL("FS"),4)="M":"M",1:"W")
- Q
- NTE ;
- D FORM
- I $P(PSOHB,HL("FS"))=6 D COMM Q
- I $P(PSOHB,HL("FS"))=7 D SIG Q
- Q
- COMM ;Process Provider Comments
- I $O(PSOHB(""))'="" D COMM^PSOHLINL Q
- K ^UTILITY($J,"W")
- S X=$P(PSOHB,HL("FS"),3,999)
- I $L(X)>245 S PSOXLONG=1 Q
- S DIWL=1,DIWR=70,DIWF="" D ^DIWP
- D ENCOMM^PSOHLINL
- K ^UTILITY($J,"W")
- Q
- SIG ;Process SIG
- I $O(PSOHB(""))'="" D SIG^PSOHLINL Q
- K ^UTILITY($J,"W")
- S X=$P(PSOHB,HL("FS"),3,999)
- I $L(X)>245 S PSOXLONG=1 Q
- S DIWL=1,DIWR=70,DIWF="" D ^DIWP
- D ENSIG^PSOHLINL
- K ^UTILITY($J,"W")
- Q
- FORM ;
- S PSOHB=$E(PSOHB,(4+$L(HL("FS"))),$L(PSOHB))
- Q
- ;AND IF YOU ADD PSOHLNEW TO THE PATCH, FIX THE HEADER OF THE 3 NODE TO MATCH HOW YOU DID IT IN PSOHCPRS. SINCE IT IS A WORD PROCESSING FIELD
- ; And maybe fix -1 problem if no related institution is found
- ; AND IF YOU PATCH PSOHLSN1, AT THE rxr POINT, INITIALIZE RTENAME AT THE BEGINNING OF EACH LOOP
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOHLINC 3926 printed Feb 18, 2025@23:56:20 Page 2
- PSOHLINC ;BIR/RTR - Process incoming order messages from CHCS ;06/17/02
- +1 ;;7.0;OUTPATIENT PHARMACY;**111,143**;DEC 1997
- +2 ;
- EN ;Process incoming outpatient order messages
- +1 NEW PSOXLONG,PSOHDFOR,PSOHLTAG,PSOHBDS,PSOHMSG,PSOHLMIS,PSOHLRS,PSOHEID,PSOHEIDS,PSOHFSP,PSOHLNOP,PSOXHI,PSOHLZ,PSOHLZC,PSOHLRXO,PSOXMH,PSOHY,PSOEXMS,PSOEXXQ,PSOHG,PSOBH,X,Y
- +2 IF '$GET(DT)
- SET DT=$$DT^XLFDT
- +3 SET (PSOXLONG,PSOHLRXO,PSOHLNOP,PSOHDFOR)=0
- +4 SET PSOHFSP=$EXTRACT(HL("ECH"),1)
- +5 KILL PSOHLMIS
- +6 FOR PSOXHI=1:1
- KILL PSOHB
- XECUTE HLNEXT
- if HLQUIT'>0!(PSOHLNOP)!(PSOHDFOR)!(PSOXLONG)
- QUIT
- SET PSOHB=HLNODE
- SET PSOXMH=$EXTRACT(PSOHB,1,3)
- Begin DoDot:1
- +7 SET PSOHG=0
- FOR
- SET PSOHG=$ORDER(HLNODE(PSOHG))
- if 'PSOHG!(PSOHLNOP)!(PSOHDFOR)!(PSOXLONG)
- QUIT
- SET PSOHB(PSOHG)=HLNODE(PSOHG)
- +8 IF (PSOXMH'?3U)
- IF (PSOXMH'?2U1N)
- SET PSOHDFOR=1
- QUIT
- +9 IF $TEXT(@PSOXMH)]""
- DO @PSOXMH
- End DoDot:1
- +10 ;Quit if not a Pharmacy message, no acknowledgements
- +11 IF $GET(PSOHLNOP)
- QUIT
- +12 IF $GET(PSOHY("OCC"))="CA"
- DO ENDC^PSOHLDC
- QUIT
- +13 IF PSOXLONG
- SET PSOEXMS="Invalid NTE segment, greater than 245 characters."
- DO NAK^PSOHLEXC
- QUIT
- +14 SET (PSOHBDS,PSOEXXQ)=0
- +15 IF PSOHDFOR
- SET PSOEXMS="Invalid message structure."
- DO NAK^PSOHLEXC
- QUIT
- +16 FOR PSOHMSG="MSH","PID","PV1","ORC","RXO"
- if PSOEXXQ
- QUIT
- IF '$DATA(PSOHLMIS(PSOHMSG))
- SET PSOEXMS="Missing "_PSOHMSG_" segment."
- SET PSOHBDS=1
- DO NAK^PSOHLEXC
- +17 ;Quit if segment is missing
- +18 IF $GET(PSOEXXQ)
- QUIT
- +19 ;Quit if not a Pharmacy message, no acknowledgements
- +20 ;I $G(PSOHLNOP) Q
- +21 ;check for data exceptions
- +22 DO CHECK^PSOHLEXC
- +23 ;PSOEXXQ set if a NAK was sent back
- +24 IF $GET(PSOEXXQ)
- QUIT
- +25 ;Enter order into Pending Outpatient Orders file
- +26 DO ADD^PSOHCPRS
- +27 ;Send successful acknowledgement if PSOEXXQ not set
- +28 IF '$GET(PSOEXXQ)
- DO ACK^PSOHLEXC
- +29 QUIT
- +30 ;What about regular acknowledgements? handled by HL7 package somehow
- +31 QUIT
- MSH ;Process MSH segment
- +1 IF $PIECE(PSOHB,HL("FS"),5)'="PSO RECEIVE"
- SET PSOHLNOP=1
- +2 SET PSOHLMIS("MSH")=""
- +3 QUIT
- PID ;Process PID segment
- +1 DO FORM
- +2 SET PSOHY("PAT")=+$PIECE(PSOHB,HL("FS"),3)
- +3 SET PSOHLMIS("PID")=""
- +4 QUIT
- PV1 ;Process PV1 segment
- +1 DO FORM
- +2 SET PSOHY("LOC")=+$PIECE(PSOHB,HL("FS"),3)
- +3 SET PSOHLMIS("PV1")=""
- +4 QUIT
- DG1 ;Process DG1 segment ; future use
- +1 DO FORM
- +2 SET $PIECE(PSOHY("ICD"),U,$PIECE(PSOHB,HL("FS"),1))=$PIECE(PSOHB,HL("FS"),3)
- ZCL ;future use
- QUIT
- +1 ;
- ORC ;Process ORC segment
- +1 ;For future use in processing NTE's, if other segments get NTE(6) or (7)
- SET PSOHLRXO=1
- +2 DO FORM
- +3 IF $ORDER(PSOHB(""))'=""
- DO ORC^PSOHLINL
- QUIT
- +4 SET PSOHY("OCC")=$PIECE(PSOHB,HL("FS"))
- +5 ;Set priority to Routine
- +6 SET PSOHY("PRIOR")="R"
- +7 SET PSOHY("CHNUM")=$PIECE($PIECE(PSOHB,HL("FS"),2),PSOHFSP)
- +8 DO NOW^%DTC
- SET PSOHY("EDT")=%
- +9 SET X=$PIECE(PSOHB,HL("FS"),9)
- Begin DoDot:1
- +10 IF X
- SET PSOHY("SDT")=$$HL7TFM^XLFDT(X)
- QUIT
- +11 SET PSOHY("SDT")=$GET(PSOHY("EDT"))
- End DoDot:1
- +12 SET PSOHY("ENTER")=+$PIECE(PSOHB,HL("FS"),10)
- +13 SET PSOHY("PROV")=+$PIECE(PSOHB,HL("FS"),12)
- +14 SET PSOHLMIS("ORC")=""
- +15 QUIT
- RXO ;Process RXO segment
- +1 DO FORM
- +2 IF $ORDER(PSOHB(""))'=""
- DO RXO^PSOHLINL
- QUIT
- +3 SET PSOHY("DRUG")=+$PIECE(PSOHB,HL("FS"),10)
- +4 SET PSOHY("QTY")=$PIECE(PSOHB,HL("FS"),11)
- +5 SET PSOHY("REF")=$PIECE(PSOHB,HL("FS"),13)
- +6 SET PSOHLMIS("RXO")=""
- +7 QUIT
- RXR ;Process RXR segment
- +1 DO FORM
- +2 QUIT
- ZRX ;Process ZRX segment
- +1 DO FORM
- +2 SET PSOHY("PICK")=$SELECT($PIECE(PSOHB,HL("FS"),4)="M":"M",1:"W")
- +3 QUIT
- NTE ;
- +1 DO FORM
- +2 IF $PIECE(PSOHB,HL("FS"))=6
- DO COMM
- QUIT
- +3 IF $PIECE(PSOHB,HL("FS"))=7
- DO SIG
- QUIT
- +4 QUIT
- COMM ;Process Provider Comments
- +1 IF $ORDER(PSOHB(""))'=""
- DO COMM^PSOHLINL
- QUIT
- +2 KILL ^UTILITY($JOB,"W")
- +3 SET X=$PIECE(PSOHB,HL("FS"),3,999)
- +4 IF $LENGTH(X)>245
- SET PSOXLONG=1
- QUIT
- +5 SET DIWL=1
- SET DIWR=70
- SET DIWF=""
- DO ^DIWP
- +6 DO ENCOMM^PSOHLINL
- +7 KILL ^UTILITY($JOB,"W")
- +8 QUIT
- SIG ;Process SIG
- +1 IF $ORDER(PSOHB(""))'=""
- DO SIG^PSOHLINL
- QUIT
- +2 KILL ^UTILITY($JOB,"W")
- +3 SET X=$PIECE(PSOHB,HL("FS"),3,999)
- +4 IF $LENGTH(X)>245
- SET PSOXLONG=1
- QUIT
- +5 SET DIWL=1
- SET DIWR=70
- SET DIWF=""
- DO ^DIWP
- +6 DO ENSIG^PSOHLINL
- +7 KILL ^UTILITY($JOB,"W")
- +8 QUIT
- FORM ;
- +1 SET PSOHB=$EXTRACT(PSOHB,(4+$LENGTH(HL("FS"))),$LENGTH(PSOHB))
- +2 QUIT
- +3 ;AND IF YOU ADD PSOHLNEW TO THE PATCH, FIX THE HEADER OF THE 3 NODE TO MATCH HOW YOU DID IT IN PSOHCPRS. SINCE IT IS A WORD PROCESSING FIELD
- +4 ; And maybe fix -1 problem if no related institution is found
- +5 ; AND IF YOU PATCH PSOHLSN1, AT THE rxr POINT, INITIALIZE RTENAME AT THE BEGINNING OF EACH LOOP