- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLSN2.m
r613 r623 1 PSOHLSN2 ;BIR/LE - Utilities for PSOHLSN1 ;02/27/04 2 ;;7.0;OUTPATIENT PHARMACY;**143,226,239,225**;DEC 1997;Build 29 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,8 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:9 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 their CIDC switch is off. Always send both ZCL and ZSC for consistency 38 ZSC S PSOCPS=$$DT^PSOMLLDT S LIMIT=$S($G(PSOCPS):8,1:1) X NULLFLDS 39 S FIELD(0)="ZSC" N JJJ,PSOICD 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")),"^") 44 .. F JJJ=2:1:8 S FIELD(JJJ)=$P($G(^PSRX(PSRXIEN,"IBQ")),"^",JJJ) 45 .D SEG^PSOHLSN1 46 I $D(^PSRX(PSRXIEN,"ICD",1,0)) D 47 . S PSOICD=$G(^PSRX(PSRXIEN,"ICD",1,0)) 48 . F JJJ=2:1:9 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 .. I JJJ=9 S FIELD(8)=$P(PSOICD,"^",JJJ) ;SHAD 57 . D SEG^PSOHLSN1 58 Q 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
Note:
See TracChangeset
for help on using the changeset viewer.
