- 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 Feb 18, 2025@23:56:38 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