Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSOHLSN2

PSOHLSN2.m

Go to the documentation of this file.
  1. PSOHLSN2 ;BIR/LE - Utilities for PSOHLSN1 ;02/27/04
  1. ;;7.0;OUTPATIENT PHARMACY;**143,226,239,225,404,465**;DEC 1997;Build 2
  1. ;
  1. ;Ext ref to $$ICDDX^ICDCODE sup DBIA 3990
  1. ;Ext ref to $$ICDD^ICDCODE sup DBIA 3990
  1. ;
  1. 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.
  1. Q ;*465
  1. Q:'$D(^PSRX(PSRXIEN,"ICD",1,0))
  1. N LP,DG,DXDESC,I
  1. S LIMIT=4,FIELD(0)="DG1",FIELD(4)=""
  1. ;I '$D(^PSRX(PSRXIEN,"ICD",1,0)) S FIELD(1)=1,FIELD(2)="",FIELD(3)="^^^^^" D SEG^PSOHLSN1 Q
  1. I $P(^PSRX(PSRXIEN,"ICD",1,0),"^",1)="" Q ;S FIELD(1)=1,FIELD(2)="",FIELD(3)="^^^^^" D SEG^PSOHLSN1 Q
  1. F I=1:1:8 D
  1. . Q:'$D(^PSRX(PSRXIEN,"ICD",I,0))
  1. . S PSOICD="",PSOICD=^PSRX(PSRXIEN,"ICD",I,0) Q:$P(PSOICD,U,1)=""
  1. . S (DG,DXDESC)=""
  1. . I $P(PSOICD,U,1)'="" D
  1. .. N PSOICDD,PSOARRY,PSOICDX,PSOFILDT ;*404
  1. .. S PSOFILDT=$$GET1^DIQ(52,PSRXIEN_",","22","I") ;*404
  1. .. S PSOICDX=$$ICDDX^ICDCODE($P(PSOICD,U,1),PSOFILDT) ;*404
  1. .. S PSOICDD=$$ICDD^ICDCODE($P(PSOICDX,U,2),"PSOARRY",PSOFILDT) ;*404
  1. .. S DXDESC=PSOARRY(1),FIELD(1)=I,FIELD(2)="" ;*404
  1. .. S FIELD(3)=$P(PSOICD,U,1)_U_DXDESC_U_"80"_U_$P(PSOICDX,U,2)_U_DXDESC_U_"ICD9" ;*404
  1. .. D SEG^PSOHLSN1
  1. K PSOICD("K")
  1. Q
  1. ZCL N STOP,IBQ,ICD,I,JJJ,EI
  1. S LIMIT=3,FIELD(0)="ZCL"
  1. 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
  1. . S FIELD(1)=1,FIELD(2)=3
  1. . S EI="",EI=^PSRX(PSRXIEN,"IBQ")
  1. . 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
  1. E F I=1:1:8 D
  1. . Q:'$D(^PSRX(PSRXIEN,"ICD",I,0))
  1. . S PSOICD=^PSRX(PSRXIEN,"ICD",I,0),ICD=$P(PSOICD,"^",1)
  1. . Q:ICD=""&(I>1)
  1. . F JJJ=2:1:9 S EI=$P(PSOICD,U,JJJ),FIELD(2)=JJJ-1 D
  1. .. S FIELD(1)=$S(ICD="":1,1:I)
  1. .. ;S FIELD(3)=$S(EI=1:EI,1:0)
  1. .. S FIELD(3)=$S(EI=1:EI,EI=0:EI,1:"")
  1. .. D SEG^PSOHLSN1
  1. K PSOICD
  1. Q
  1. ;CPRS doesn't look at the ZCL segment when their CIDC switch is off. Always send both ZCL and ZSC for consistency
  1. ZSC S PSOCPS=$$DT^PSOMLLDT S LIMIT=$S($G(PSOCPS):8,1:1) X NULLFLDS
  1. S FIELD(0)="ZSC" N JJJ,PSOICD
  1. I '$D(^PSRX(PSRXIEN,"ICD",1,0)) D
  1. . I '$G(PSOCPS) S FIELD(1)=$S($P($G(^PSRX(PSRXIEN,"IB")),"^"):"NSC",1:"SC")
  1. . I $G(PSOCPS) D
  1. .. S FIELD(1)=$P($G(^PSRX(PSRXIEN,"IBQ")),"^")
  1. .. F JJJ=2:1:8 S FIELD(JJJ)=$P($G(^PSRX(PSRXIEN,"IBQ")),"^",JJJ)
  1. .D SEG^PSOHLSN1
  1. I $D(^PSRX(PSRXIEN,"ICD",1,0)) D
  1. . S PSOICD=$G(^PSRX(PSRXIEN,"ICD",1,0))
  1. . F JJJ=2:1:9 D
  1. .. I JJJ=2 S FIELD(3)=$P(PSOICD,"^",JJJ) ;AO
  1. .. I JJJ=3 S FIELD(4)=$P(PSOICD,"^",JJJ) ;IR
  1. .. I JJJ=4 S FIELD(1)=$P(PSOICD,"^",JJJ) ;SC
  1. .. I JJJ=5 S FIELD(5)=$P(PSOICD,"^",JJJ) ;EC
  1. .. I JJJ=6 S FIELD(2)=$P(PSOICD,"^",JJJ) ;MST
  1. .. I JJJ=7 S FIELD(6)=$P(PSOICD,"^",JJJ) ;HNC
  1. .. I JJJ=8 S FIELD(7)=$P(PSOICD,"^",JJJ) ;CV
  1. .. I JJJ=9 S FIELD(8)=$P(PSOICD,"^",JJJ) ;SHAD
  1. . D SEG^PSOHLSN1
  1. Q