PSOHLSN2 ;BIR/LE - Utilities for PSOHLSN1 ;02/27/04
;;7.0;OUTPATIENT PHARMACY;**143,226,239,225**;DEC 1997;Build 29
;
DG1 ;this section builds both DG1 segments
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
.. S DXDESC=$$GET1^DIQ(80,$P(PSOICD,U,1)_",",10),FIELD(1)=I,FIELD(2)=""
.. S FIELD(3)=$P(PSOICD,U,1)_U_DXDESC_U_"80"_U_$$GET1^DIQ(80,$P(PSOICD,U,1)_",",.01)_U_DXDESC_U_"ICD9"
.. 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
PSOHLSN2 ;BIR/LE - Utilities for PSOHLSN1 ;02/27/04
+1 ;;7.0;OUTPATIENT PHARMACY;**143,226,239,225**;DEC 1997;Build 29
+2 ;
DG1 ;this section builds both DG1 segments
+1 IF '$DATA(^PSRX(PSRXIEN,"ICD",1,0))
QUIT
+2 NEW LP,DG,DXDESC,I
+3 SET LIMIT=4
SET FIELD(0)="DG1"
SET FIELD(4)=""
+4 ;I '$D(^PSRX(PSRXIEN,"ICD",1,0)) S FIELD(1)=1,FIELD(2)="",FIELD(3)="^^^^^" D SEG^PSOHLSN1 Q
+5 ;S FIELD(1)=1,FIELD(2)="",FIELD(3)="^^^^^" D SEG^PSOHLSN1 Q
IF $PIECE(^PSRX(PSRXIEN,"ICD",1,0),"^",1)=""
QUIT
+6 FOR I=1:1:8
Begin DoDot:1
+7 IF '$DATA(^PSRX(PSRXIEN,"ICD",I,0))
QUIT
+8 SET PSOICD=""
SET PSOICD=^PSRX(PSRXIEN,"ICD",I,0)
IF $PIECE(PSOICD,U,1)=""
QUIT
+9 SET (DG,DXDESC)=""
+10 IF $PIECE(PSOICD,U,1)'=""
Begin DoDot:2
+11 SET DXDESC=$$GET1^DIQ(80,$PIECE(PSOICD,U,1)_",",10)
SET FIELD(1)=I
SET FIELD(2)=""
+12 SET FIELD(3)=$PIECE(PSOICD,U,1)_U_DXDESC_U_"80"_U_$$GET1^DIQ(80,$PIECE(PSOICD,U,1)_",",.01)_U_DXDESC_U_"ICD9"
+13 DO SEG^PSOHLSN1
End DoDot:2
End DoDot:1
+14 KILL PSOICD("K")
+15 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
