PSUDEM3.m

PSUDEM3 ;BIR/DAM - ICD9 codes for Outpatient Encounter Extract ; 20 DEC 2001

 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005

 ;

 ;DBIA's

 ; Reference to file 80         supported by DBIA 10082

 ; Reference to file 9000010.18 supported by DBIA 3560

 ;

EN ;EN   Called from PSUDEM2

 D ICD

 D CLEAN

 Q

 ;

ICD ;Find all ICD9 pointers  associated with Patient pointer

 ;

 N PSUICD

 S PSUC1=0

 F  S PSUC1=$O(^AUPNVCPT("C",PSUPT,PSUC1)) Q:PSUC1=""  D    ;V CPT IEN

 .I $P($G(^AUPNVCPT(PSUC1,0)),U,3)=$G(PSUVIEN) D  ;V CPT IEN=Visit IEN

 ..S PSUICD=$P($G(^AUPNVCPT(PSUC1,0)),U,5) D ICD1           ;ICD9 Ptr

 ..S PSUCPT=$P($G(^AUPNVCPT(PSUC1,0)),U,1) D EN^PSUDEM6  ;grab CPT codes

 I '$D(^AUPNVCPT("C",PSUPT)) S PSUCPT="" D EN^PSUDEM6

 D FIN

 Q

 ;

ICD1 ;Find ICD9 codes from pointers and place in an array 

 ;

 ;

 N PSUID2

 I PSUICD S PSUID2=$P($G(^ICD9(PSUICD,0)),U) D

 .I $D(PSUID2) S ^XTMP("PSU_"_PSUJOB,"PSUTMP1",PSUVIEN,PSUID2)=""  ;ICD9 codes set into array 

 ;

 Q

 ;

FIN ;$O through array, and set codes into the Outpatient Visit

 ;Encounter global, ^XTMP("PSU_"_PSUJOB,"PSUOPV"

 ;

 ;

 S PSUIDF=0

 S I=8

 F  S PSUIDF=$O(^XTMP("PSU_"_PSUJOB,"PSUTMP1",PSUVIEN,PSUIDF)) Q:'PSUIDF  Q:I=17  D

 .S $P(^XTMP("PSU_"_PSUJOB,"PSUOPV",PSUVIEN),U,I)=PSUIDF

 .S I=I+1

 ;

 F N=8:1:16 I '$P($G(^XTMP("PSU_"_PSUJOB,"PSUOPV",PSUVIEN)),U,N) D

 .S $P(^XTMP("PSU_"_PSUJOB,"PSUOPV",PSUVIEN),U,N)=""

 Q

 ;

CLEAN ;Delete all ^XTMP("PSU_"_PSUJOB,"PSUOPV" entries that do not have associated

 ;ICD9 or CPT codes.

 ;

 S PSUCL=0

 F  S PSUCL=$O(^XTMP("PSU_"_PSUJOB,"PSUOPV",PSUCL)) Q:'PSUCL  D

 .I $P(^XTMP("PSU_"_PSUJOB,"PSUOPV",PSUCL),U,7)="" D

 ..I $P(^XTMP("PSU_"_PSUJOB,"PSUOPV",PSUCL),U,17)="" K ^XTMP("PSU_"_PSUJOB,"PSUOPV",PSUCL)

 Q

PSUDEM3   ;BIR/DAM - ICD9 codes for Outpatient Encounter Extract ; 20 DEC 2001

 +1       ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005

 +2       ;

 +3       ;DBIA's

 +4       ; Reference to file 80         supported by DBIA 10082

 +5       ; Reference to file 9000010.18 supported by DBIA 3560

 +6       ;

EN        ;EN   Called from PSUDEM2

 +1        DO ICD

 +2        DO CLEAN

 +3        QUIT 

 +4       ;

ICD       ;Find all ICD9 pointers  associated with Patient pointer

 +1       ;

 +2        NEW PSUICD

 +3        SET PSUC1=0

 +4       ;V CPT IEN

           FOR 

               SET PSUC1=$ORDER(^AUPNVCPT("C",PSUPT,PSUC1))

               IF PSUC1=""

                   QUIT 

               Begin DoDot:1

 +5       ;V CPT IEN=Visit IEN

                   IF $PIECE($GET(^AUPNVCPT(PSUC1,0)),U,3)=$GET(PSUVIEN)

                       Begin DoDot:2

 +6       ;ICD9 Ptr

                           SET PSUICD=$PIECE($GET(^AUPNVCPT(PSUC1,0)),U,5)

                           DO ICD1

 +7       ;grab CPT codes

                           SET PSUCPT=$PIECE($GET(^AUPNVCPT(PSUC1,0)),U,1)

                           DO EN^PSUDEM6

                       End DoDot:2

               End DoDot:1

 +8        IF '$DATA(^AUPNVCPT("C",PSUPT))

               SET PSUCPT=""

               DO EN^PSUDEM6

 +9        DO FIN

 +10       QUIT 

 +11      ;

ICD1      ;Find ICD9 codes from pointers and place in an array 

 +1       ;

 +2       ;

 +3        NEW PSUID2

 +4        IF PSUICD

               SET PSUID2=$PIECE($GET(^ICD9(PSUICD,0)),U)

               Begin DoDot:1

 +5       ;ICD9 codes set into array 

                   IF $DATA(PSUID2)

                       SET ^XTMP("PSU_"_PSUJOB,"PSUTMP1",PSUVIEN,PSUID2)=""

               End DoDot:1

 +6       ;

 +7        QUIT 

 +8       ;

FIN       ;$O through array, and set codes into the Outpatient Visit

 +1       ;Encounter global, ^XTMP("PSU_"_PSUJOB,"PSUOPV"

 +2       ;

 +3       ;

 +4        SET PSUIDF=0

 +5        SET I=8

 +6        FOR 

               SET PSUIDF=$ORDER(^XTMP("PSU_"_PSUJOB,"PSUTMP1",PSUVIEN,PSUIDF))

               IF 'PSUIDF

                   QUIT 

               IF I=17

                   QUIT 

               Begin DoDot:1

 +7                SET $PIECE(^XTMP("PSU_"_PSUJOB,"PSUOPV",PSUVIEN),U,I)=PSUIDF

 +8                SET I=I+1

               End DoDot:1

 +9       ;

 +10       FOR N=8:1:16

               IF '$PIECE($GET(^XTMP("PSU_"_PSUJOB,"PSUOPV",PSUVIEN)),U,N)

                   Begin DoDot:1

 +11                   SET $PIECE(^XTMP("PSU_"_PSUJOB,"PSUOPV",PSUVIEN),U,N)=""

                   End DoDot:1

 +12       QUIT 

 +13      ;

CLEAN     ;Delete all ^XTMP("PSU_"_PSUJOB,"PSUOPV" entries that do not have associated

 +1       ;ICD9 or CPT codes.

 +2       ;

 +3        SET PSUCL=0

 +4        FOR 

               SET PSUCL=$ORDER(^XTMP("PSU_"_PSUJOB,"PSUOPV",PSUCL))

               IF 'PSUCL

                   QUIT 

               Begin DoDot:1

 +5                IF $PIECE(^XTMP("PSU_"_PSUJOB,"PSUOPV",PSUCL),U,7)=""

                       Begin DoDot:2

 +6                        IF $PIECE(^XTMP("PSU_"_PSUJOB,"PSUOPV",PSUCL),U,17)=""

                               KILL ^XTMP("PSU_"_PSUJOB,"PSUOPV",PSUCL)

                       End DoDot:2

               End DoDot:1

 +7        QUIT