PSOHLSN2 ;BIR/LE - Utilities for PSOHLSN1 ;02/27/04
;;7.0;OUTPATIENT PHARMACY;**143,226,239,225,404,465**;DEC 1997;Build 2
;
;Ext ref to $$ICDDX^ICDCODE sup DBIA 3990
;Ext ref to $$ICDD^ICDCODE sup DBIA 3990
;
DG1 ;this section builds both DG1 segments
;IF IT IS DECIDED IN THE FUTURE TO CAPTURE THEN SEND ICD CODES, THE CODE BELOW WILL NEED TO BE RE-EVALUATED FOR ANY NECESSARY CHANGES.
Q ;*465
Q:'$D(^PSRX(PSRXIEN,"ICD",1,0))
N LP,DG,DXDESC,I
S LIMIT=4,FIELD(0)="DG1",FIELD(4)=""
;I '$D(^PSRX(PSRXIEN,"ICD",1,0)) S FIELD(1)=1,FIELD(2)="",FIELD(3)="^^^^^" D SEG^PSOHLSN1 Q
I $P(^PSRX(PSRXIEN,"ICD",1,0),"^",1)="" Q ;S FIELD(1)=1,FIELD(2)="",FIELD(3)="^^^^^" D SEG^PSOHLSN1 Q
F I=1:1:8 D
. Q:'$D(^PSRX(PSRXIEN,"ICD",I,0))
. S PSOICD="",PSOICD=^PSRX(PSRXIEN,"ICD",I,0) Q:$P(PSOICD,U,1)=""
. S (DG,DXDESC)=""
. I $P(PSOICD,U,1)'="" D
.. N PSOICDD,PSOARRY,PSOICDX,PSOFILDT ;*404
.. S PSOFILDT=$$GET1^DIQ(52,PSRXIEN_",","22","I") ;*404
.. S PSOICDX=$$ICDDX^ICDCODE($P(PSOICD,U,1),PSOFILDT) ;*404
.. S PSOICDD=$$ICDD^ICDCODE($P(PSOICDX,U,2),"PSOARRY",PSOFILDT) ;*404
.. S DXDESC=PSOARRY(1),FIELD(1)=I,FIELD(2)="" ;*404
.. S FIELD(3)=$P(PSOICD,U,1)_U_DXDESC_U_"80"_U_$P(PSOICDX,U,2)_U_DXDESC_U_"ICD9" ;*404
.. D SEG^PSOHLSN1
K PSOICD("K")
Q
ZCL N STOP,IBQ,ICD,I,JJJ,EI
S LIMIT=3,FIELD(0)="ZCL"
I '$D(^PSRX(PSRXIEN,"ICD"))&($D(^PSRX(PSRXIEN,"IBQ"))) D ;For edits; currently CPRS doesn't update SC/EI for edits, but just in case they start
. S FIELD(1)=1,FIELD(2)=3
. S EI="",EI=^PSRX(PSRXIEN,"IBQ")
. S JJJ=0 F I=3,4,1,5,2,6,7,8 S JJJ=JJJ+1,FIELD(3)=$P(EI,U,I) S FIELD(1)=1,FIELD(2)=JJJ D SEG^PSOHLSN1
E F I=1:1:8 D
. Q:'$D(^PSRX(PSRXIEN,"ICD",I,0))
. S PSOICD=^PSRX(PSRXIEN,"ICD",I,0),ICD=$P(PSOICD,"^",1)
. Q:ICD=""&(I>1)
. F JJJ=2:1:9 S EI=$P(PSOICD,U,JJJ),FIELD(2)=JJJ-1 D
.. S FIELD(1)=$S(ICD="":1,1:I)
.. ;S FIELD(3)=$S(EI=1:EI,1:0)
.. S FIELD(3)=$S(EI=1:EI,EI=0:EI,1:"")
.. D SEG^PSOHLSN1
K PSOICD
Q
;CPRS doesn't look at the ZCL segment when their CIDC switch is off. Always send both ZCL and ZSC for consistency
ZSC S PSOCPS=$$DT^PSOMLLDT S LIMIT=$S($G(PSOCPS):8,1:1) X NULLFLDS
S FIELD(0)="ZSC" N JJJ,PSOICD
I '$D(^PSRX(PSRXIEN,"ICD",1,0)) D
. I '$G(PSOCPS) S FIELD(1)=$S($P($G(^PSRX(PSRXIEN,"IB")),"^"):"NSC",1:"SC")
. I $G(PSOCPS) D
.. S FIELD(1)=$P($G(^PSRX(PSRXIEN,"IBQ")),"^")
.. F JJJ=2:1:8 S FIELD(JJJ)=$P($G(^PSRX(PSRXIEN,"IBQ")),"^",JJJ)
.D SEG^PSOHLSN1
I $D(^PSRX(PSRXIEN,"ICD",1,0)) D
. S PSOICD=$G(^PSRX(PSRXIEN,"ICD",1,0))
. F JJJ=2:1:9 D
.. I JJJ=2 S FIELD(3)=$P(PSOICD,"^",JJJ) ;AO
.. I JJJ=3 S FIELD(4)=$P(PSOICD,"^",JJJ) ;IR
.. I JJJ=4 S FIELD(1)=$P(PSOICD,"^",JJJ) ;SC
.. I JJJ=5 S FIELD(5)=$P(PSOICD,"^",JJJ) ;EC
.. I JJJ=6 S FIELD(2)=$P(PSOICD,"^",JJJ) ;MST
.. I JJJ=7 S FIELD(6)=$P(PSOICD,"^",JJJ) ;HNC
.. I JJJ=8 S FIELD(7)=$P(PSOICD,"^",JJJ) ;CV
.. I JJJ=9 S FIELD(8)=$P(PSOICD,"^",JJJ) ;SHAD
. D SEG^PSOHLSN1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOHLSN2 2990 printed Sep 23, 2025@20:06:37 Page 2
PSOHLSN2 ;BIR/LE - Utilities for PSOHLSN1 ;02/27/04
+1 ;;7.0;OUTPATIENT PHARMACY;**143,226,239,225,404,465**;DEC 1997;Build 2
+2 ;
+3 ;Ext ref to $$ICDDX^ICDCODE sup DBIA 3990
+4 ;Ext ref to $$ICDD^ICDCODE sup DBIA 3990
+5 ;
DG1 ;this section builds both DG1 segments
+1 ;IF IT IS DECIDED IN THE FUTURE TO CAPTURE THEN SEND ICD CODES, THE CODE BELOW WILL NEED TO BE RE-EVALUATED FOR ANY NECESSARY CHANGES.
+2 ;*465
QUIT
+3 if '$DATA(^PSRX(PSRXIEN,"ICD",1,0))
QUIT
+4 NEW LP,DG,DXDESC,I
+5 SET LIMIT=4
SET FIELD(0)="DG1"
SET FIELD(4)=""
+6 ;I '$D(^PSRX(PSRXIEN,"ICD",1,0)) S FIELD(1)=1,FIELD(2)="",FIELD(3)="^^^^^" D SEG^PSOHLSN1 Q
+7 ;S FIELD(1)=1,FIELD(2)="",FIELD(3)="^^^^^" D SEG^PSOHLSN1 Q
IF $PIECE(^PSRX(PSRXIEN,"ICD",1,0),"^",1)=""
QUIT
+8 FOR I=1:1:8
Begin DoDot:1
+9 if '$DATA(^PSRX(PSRXIEN,"ICD",I,0))
QUIT
+10 SET PSOICD=""
SET PSOICD=^PSRX(PSRXIEN,"ICD",I,0)
if $PIECE(PSOICD,U,1)=""
QUIT
+11 SET (DG,DXDESC)=""
+12 IF $PIECE(PSOICD,U,1)'=""
Begin DoDot:2
+13 ;*404
NEW PSOICDD,PSOARRY,PSOICDX,PSOFILDT
+14 ;*404
SET PSOFILDT=$$GET1^DIQ(52,PSRXIEN_",","22","I")
+15 ;*404
SET PSOICDX=$$ICDDX^ICDCODE($PIECE(PSOICD,U,1),PSOFILDT)
+16 ;*404
SET PSOICDD=$$ICDD^ICDCODE($PIECE(PSOICDX,U,2),"PSOARRY",PSOFILDT)
+17 ;*404
SET DXDESC=PSOARRY(1)
SET FIELD(1)=I
SET FIELD(2)=""
+18 ;*404
SET FIELD(3)=$PIECE(PSOICD,U,1)_U_DXDESC_U_"80"_U_$PIECE(PSOICDX,U,2)_U_DXDESC_U_"ICD9"
+19 DO SEG^PSOHLSN1
End DoDot:2
End DoDot:1
+20 KILL PSOICD("K")
+21 QUIT
ZCL NEW STOP,IBQ,ICD,I,JJJ,EI
+1 SET LIMIT=3
SET FIELD(0)="ZCL"
+2 ;For edits; currently CPRS doesn't update SC/EI for edits, but just in case they start
IF '$DATA(^PSRX(PSRXIEN,"ICD"))&($DATA(^PSRX(PSRXIEN,"IBQ")))
Begin DoDot:1
+3 SET FIELD(1)=1
SET FIELD(2)=3
+4 SET EI=""
SET EI=^PSRX(PSRXIEN,"IBQ")
+5 SET JJJ=0
FOR I=3,4,1,5,2,6,7,8
SET JJJ=JJJ+1
SET FIELD(3)=$PIECE(EI,U,I)
SET FIELD(1)=1
SET FIELD(2)=JJJ
DO SEG^PSOHLSN1
End DoDot:1
+6 IF '$TEST
FOR I=1:1:8
Begin DoDot:1
+7 if '$DATA(^PSRX(PSRXIEN,"ICD",I,0))
QUIT
+8 SET PSOICD=^PSRX(PSRXIEN,"ICD",I,0)
SET ICD=$PIECE(PSOICD,"^",1)
+9 if ICD=""&(I>1)
QUIT
+10 FOR JJJ=2:1:9
SET EI=$PIECE(PSOICD,U,JJJ)
SET FIELD(2)=JJJ-1
Begin DoDot:2
+11 SET FIELD(1)=$SELECT(ICD="":1,1:I)
+12 ;S FIELD(3)=$S(EI=1:EI,1:0)
+13 SET FIELD(3)=$SELECT(EI=1:EI,EI=0:EI,1:"")
+14 DO SEG^PSOHLSN1
End DoDot:2
End DoDot:1
+15 KILL PSOICD
+16 QUIT
+17 ;CPRS doesn't look at the ZCL segment when their CIDC switch is off. Always send both ZCL and ZSC for consistency
ZSC SET PSOCPS=$$DT^PSOMLLDT
SET LIMIT=$SELECT($GET(PSOCPS):8,1:1)
XECUTE NULLFLDS
+1 SET FIELD(0)="ZSC"
NEW JJJ,PSOICD
+2 IF '$DATA(^PSRX(PSRXIEN,"ICD",1,0))
Begin DoDot:1
+3 IF '$GET(PSOCPS)
SET FIELD(1)=$SELECT($PIECE($GET(^PSRX(PSRXIEN,"IB")),"^"):"NSC",1:"SC")
+4 IF $GET(PSOCPS)
Begin DoDot:2
+5 SET FIELD(1)=$PIECE($GET(^PSRX(PSRXIEN,"IBQ")),"^")
+6 FOR JJJ=2:1:8
SET FIELD(JJJ)=$PIECE($GET(^PSRX(PSRXIEN,"IBQ")),"^",JJJ)
End DoDot:2
+7 DO SEG^PSOHLSN1
End DoDot:1
+8 IF $DATA(^PSRX(PSRXIEN,"ICD",1,0))
Begin DoDot:1
+9 SET PSOICD=$GET(^PSRX(PSRXIEN,"ICD",1,0))
+10 FOR JJJ=2:1:9
Begin DoDot:2
+11 ;AO
IF JJJ=2
SET FIELD(3)=$PIECE(PSOICD,"^",JJJ)
+12 ;IR
IF JJJ=3
SET FIELD(4)=$PIECE(PSOICD,"^",JJJ)
+13 ;SC
IF JJJ=4
SET FIELD(1)=$PIECE(PSOICD,"^",JJJ)
+14 ;EC
IF JJJ=5
SET FIELD(5)=$PIECE(PSOICD,"^",JJJ)
+15 ;MST
IF JJJ=6
SET FIELD(2)=$PIECE(PSOICD,"^",JJJ)
+16 ;HNC
IF JJJ=7
SET FIELD(6)=$PIECE(PSOICD,"^",JJJ)
+17 ;CV
IF JJJ=8
SET FIELD(7)=$PIECE(PSOICD,"^",JJJ)
+18 ;SHAD
IF JJJ=9
SET FIELD(8)=$PIECE(PSOICD,"^",JJJ)
End DoDot:2
+19 DO SEG^PSOHLSN1
End DoDot:1
+20 QUIT
