| [623] | 1 | PSOHLSN2 ;BIR/LE - Utilities for PSOHLSN1 ;02/27/04
|
|---|
| 2 | ;;7.0;OUTPATIENT PHARMACY;**143,226,239**;DEC 1997
|
|---|
| 3 | ;
|
|---|
| 4 | DG1 ;this section builds both DG1 segments
|
|---|
| 5 | Q:'$D(^PSRX(PSRXIEN,"ICD",1,0))
|
|---|
| 6 | N LP,DG,DXDESC,I
|
|---|
| 7 | S LIMIT=4,FIELD(0)="DG1",FIELD(4)=""
|
|---|
| 8 | ;I '$D(^PSRX(PSRXIEN,"ICD",1,0)) S FIELD(1)=1,FIELD(2)="",FIELD(3)="^^^^^" D SEG^PSOHLSN1 Q
|
|---|
| 9 | I $P(^PSRX(PSRXIEN,"ICD",1,0),"^",1)="" Q ;S FIELD(1)=1,FIELD(2)="",FIELD(3)="^^^^^" D SEG^PSOHLSN1 Q
|
|---|
| 10 | F I=1:1:8 D
|
|---|
| 11 | . Q:'$D(^PSRX(PSRXIEN,"ICD",I,0))
|
|---|
| 12 | . S PSOICD="",PSOICD=^PSRX(PSRXIEN,"ICD",I,0) Q:$P(PSOICD,U,1)=""
|
|---|
| 13 | . S (DG,DXDESC)=""
|
|---|
| 14 | . I $P(PSOICD,U,1)'="" D
|
|---|
| 15 | .. S DXDESC=$$GET1^DIQ(80,$P(PSOICD,U,1)_",",10),FIELD(1)=I,FIELD(2)=""
|
|---|
| 16 | .. S FIELD(3)=$P(PSOICD,U,1)_U_DXDESC_U_"80"_U_$$GET1^DIQ(80,$P(PSOICD,U,1)_",",.01)_U_DXDESC_U_"ICD9"
|
|---|
| 17 | .. D SEG^PSOHLSN1
|
|---|
| 18 | K PSOICD("K")
|
|---|
| 19 | Q
|
|---|
| 20 | ZCL N STOP,IBQ,ICD,I,JJJ,EI
|
|---|
| 21 | S LIMIT=3,FIELD(0)="ZCL"
|
|---|
| 22 | 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
|
|---|
| 23 | . S FIELD(1)=1,FIELD(2)=3
|
|---|
| 24 | . S EI="",EI=^PSRX(PSRXIEN,"IBQ")
|
|---|
| 25 | . S JJJ=0 F I=3,4,1,5,2,6,7 S JJJ=JJJ+1,FIELD(3)=$P(EI,U,I) S FIELD(1)=1,FIELD(2)=JJJ D SEG^PSOHLSN1
|
|---|
| 26 | E F I=1:1:8 D
|
|---|
| 27 | . Q:'$D(^PSRX(PSRXIEN,"ICD",I,0))
|
|---|
| 28 | . S PSOICD=^PSRX(PSRXIEN,"ICD",I,0),ICD=$P(PSOICD,"^",1)
|
|---|
| 29 | . Q:ICD=""&(I>1)
|
|---|
| 30 | . F JJJ=2:1:8 S EI=$P(PSOICD,U,JJJ),FIELD(2)=JJJ-1 D
|
|---|
| 31 | .. S FIELD(1)=$S(ICD="":1,1:I)
|
|---|
| 32 | .. ;S FIELD(3)=$S(EI=1:EI,1:0)
|
|---|
| 33 | .. S FIELD(3)=$S(EI=1:EI,EI=0:EI,1:"")
|
|---|
| 34 | .. D SEG^PSOHLSN1
|
|---|
| 35 | K PSOICD
|
|---|
| 36 | Q
|
|---|
| 37 | ;CPRS doesn't look at the ZCL segment when thier CIDC switch is off. Always send both ZCL and ZSC for consistency
|
|---|
| 38 | ZSC S PSOCPS=$$DT^PSOMLLDT S LIMIT=$S($G(PSOCPS):7,1:1) X NULLFLDS
|
|---|
| 39 | S FIELD(0)="ZSC"
|
|---|
| 40 | I '$D(^PSRX(PSRXIEN,"ICD",1,0)) D
|
|---|
| 41 | . I '$G(PSOCPS) S FIELD(1)=$S($P($G(^PSRX(PSRXIEN,"IB")),"^"):"NSC",1:"SC")
|
|---|
| 42 | . I $G(PSOCPS) D
|
|---|
| 43 | .. S FIELD(1)=$P($G(^PSRX(PSRXIEN,"IBQ")),"^"),FIELD(2)=$P($G(^("IBQ")),"^",2),FIELD(3)=$P($G(^("IBQ")),"^",3),FIELD(4)=$P($G(^("IBQ")),"^",4),FIELD(5)=$P($G(^("IBQ")),"^",5),FIELD(6)=$P($G(^("IBQ")),"^",6),FIELD(7)=$P($G(^("IBQ")),"^",7)
|
|---|
| 44 | .D SEG^PSOHLSN1
|
|---|
| 45 | N JJJ,PSOICD
|
|---|
| 46 | I $D(^PSRX(PSRXIEN,"ICD",1,0)) D
|
|---|
| 47 | . S PSOICD=$G(^PSRX(PSRXIEN,"ICD",1,0))
|
|---|
| 48 | . F JJJ=2:1:8 D
|
|---|
| 49 | .. I JJJ=2 S FIELD(3)=$P(PSOICD,"^",JJJ) ;AO
|
|---|
| 50 | .. I JJJ=3 S FIELD(4)=$P(PSOICD,"^",JJJ) ;IR
|
|---|
| 51 | .. I JJJ=4 S FIELD(1)=$P(PSOICD,"^",JJJ) ;SC
|
|---|
| 52 | .. I JJJ=5 S FIELD(5)=$P(PSOICD,"^",JJJ) ;EC
|
|---|
| 53 | .. I JJJ=6 S FIELD(2)=$P(PSOICD,"^",JJJ) ;MST
|
|---|
| 54 | .. I JJJ=7 S FIELD(6)=$P(PSOICD,"^",JJJ) ;HNC
|
|---|
| 55 | .. I JJJ=8 S FIELD(7)=$P(PSOICD,"^",JJJ) ;CV
|
|---|
| 56 | . D SEG^PSOHLSN1
|
|---|
| 57 | Q
|
|---|
