PSUDEM9.m

PSUDEM9 ;BIR/DAM - CPT Codes for Inpatient PTF Record Extract ; 20 DEC 2001

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

 ;

 ;DBIA's

 ; Reference to file 45 supported by DBIA 3511

 ; Reference to file 80.1 supported by DBIA 10083

 ;

EN ;EN      Called from PSUDEM8

 D CPTP

 D P

 D AO

 D FIN

 ;

 Q

 ;

CPTP ;Find CPT pointers for the ^DGPT(D0,"401P" node by $ ordering

 ;through the ^DGPT(D0,"AP",Pointer) cross reference

 ;

 S I=17

 S PSUAP=0

 F  S PSUAP=$O(^DGPT(PSUC,"AP",PSUAP)) Q:'PSUAP  D

 .N PSUCPT

 .S PSUCPT=$P($G(^ICD0(PSUAP,0)),U)     ;CPT code

 .I $G(PSUCPT) S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,I,PSUCPT)=""    ;Set temp global

 .S I=I+1

 Q

 ;

P ;Find CPT pointers for the ^DGPT(D0,"P" node by $O through

 ;the ^DGPT(D0,"P","AP6",pointer,D1) cross reference

 ;

 S I=22

 S PSUP=0

 F  S PSUP=$O(^DGPT(PSUC,"P","AP6",PSUP)) Q:'PSUP  D

 .N PSUCPT

 .S PSUCPT=$P($G(^ICD0(PSUP,0)),U)      ;CPT code

 .I $G(PSUCPT) S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,I,PSUCPT)=""    ;Set temp global

 .D DEL

 .S I=I+1

 Q

 ;

DEL ;Delete duplicates

 ;

 F N=17:1:21 I $D(^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,N,PSUCPT)) D

 .K ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,I,PSUCPT)

 Q

 ;

AO ;Find CPT pointers for the ^DGPT(D0,"P" node by $O through

 ;the ^DGPT(D0,"S","AO",pointer,D1) cross reference.

 ;

 S I=27

 S PSUBP=0

 F  S PSUBP=$O(^DGPT(PSUC,"S","AO",PSUBP)) Q:'PSUBP  D

 .N PSUCPT

 .S PSUCPT=$P($G(^ICD0(PSUBP,0)),U)      ;CPT code

 .I $G(PSUCPT) S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,I,PSUCPT)=""    ;Set temp global

 .D DEL1

 .S I=I+1

 Q

 ;

DEL1 ;Delete duplicates

 ;

 F N=17:1:26 I $D(^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,N,PSUCPT)) D

 .K ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,I,PSUCPT)

 Q

 ;

FIN ;$O through temp global, and set codes into the Inpatient Record

 ;global, ^XTMP("PSU_"_PSUJOB,"PSUIPV"

 ;

 S T=0,N=29

 F  S T=$O(^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,T)) Q:'T  Q:N=44  D

 .S PSUIDF=0

 .F  S PSUIDF=$O(^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,T,PSUIDF)) Q:'PSUIDF  D

 ..S $P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUC),U,N)=PSUIDF

 ..S N=N+1

 ;

 F N=29:1:44 I '$P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUC),U,N) D

 .S $P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUC),U,N)=""    ;Set unfilled pieces to null

 S $P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUC),U,44)=""    ;Place "^" at end of record

 Q

PSUDEM9   ;BIR/DAM - CPT Codes for Inpatient PTF Record Extract ; 20 DEC 2001

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

 +2       ;

 +3       ;DBIA's

 +4       ; Reference to file 45 supported by DBIA 3511

 +5       ; Reference to file 80.1 supported by DBIA 10083

 +6       ;

EN        ;EN      Called from PSUDEM8

 +1        DO CPTP

 +2        DO P

 +3        DO AO

 +4        DO FIN

 +5       ;

 +6        QUIT 

 +7       ;

CPTP      ;Find CPT pointers for the ^DGPT(D0,"401P" node by $ ordering

 +1       ;through the ^DGPT(D0,"AP",Pointer) cross reference

 +2       ;

 +3        SET I=17

 +4        SET PSUAP=0

 +5        FOR 

               SET PSUAP=$ORDER(^DGPT(PSUC,"AP",PSUAP))

               IF 'PSUAP

                   QUIT 

               Begin DoDot:1

 +6                NEW PSUCPT

 +7       ;CPT code

                   SET PSUCPT=$PIECE($GET(^ICD0(PSUAP,0)),U)

 +8       ;Set temp global

                   IF $GET(PSUCPT)

                       SET ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,I,PSUCPT)=""

 +9                SET I=I+1

               End DoDot:1

 +10       QUIT 

 +11      ;

P         ;Find CPT pointers for the ^DGPT(D0,"P" node by $O through

 +1       ;the ^DGPT(D0,"P","AP6",pointer,D1) cross reference

 +2       ;

 +3        SET I=22

 +4        SET PSUP=0

 +5        FOR 

               SET PSUP=$ORDER(^DGPT(PSUC,"P","AP6",PSUP))

               IF 'PSUP

                   QUIT 

               Begin DoDot:1

 +6                NEW PSUCPT

 +7       ;CPT code

                   SET PSUCPT=$PIECE($GET(^ICD0(PSUP,0)),U)

 +8       ;Set temp global

                   IF $GET(PSUCPT)

                       SET ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,I,PSUCPT)=""

 +9                DO DEL

 +10               SET I=I+1

               End DoDot:1

 +11       QUIT 

 +12      ;

DEL       ;Delete duplicates

 +1       ;

 +2        FOR N=17:1:21

               IF $DATA(^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,N,PSUCPT))

                   Begin DoDot:1

 +3                    KILL ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,I,PSUCPT)

                   End DoDot:1

 +4        QUIT 

 +5       ;

AO        ;Find CPT pointers for the ^DGPT(D0,"P" node by $O through

 +1       ;the ^DGPT(D0,"S","AO",pointer,D1) cross reference.

 +2       ;

 +3        SET I=27

 +4        SET PSUBP=0

 +5        FOR 

               SET PSUBP=$ORDER(^DGPT(PSUC,"S","AO",PSUBP))

               IF 'PSUBP

                   QUIT 

               Begin DoDot:1

 +6                NEW PSUCPT

 +7       ;CPT code

                   SET PSUCPT=$PIECE($GET(^ICD0(PSUBP,0)),U)

 +8       ;Set temp global

                   IF $GET(PSUCPT)

                       SET ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,I,PSUCPT)=""

 +9                DO DEL1

 +10               SET I=I+1

               End DoDot:1

 +11       QUIT 

 +12      ;

DEL1      ;Delete duplicates

 +1       ;

 +2        FOR N=17:1:26

               IF $DATA(^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,N,PSUCPT))

                   Begin DoDot:1

 +3                    KILL ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,I,PSUCPT)

                   End DoDot:1

 +4        QUIT 

 +5       ;

FIN       ;$O through temp global, and set codes into the Inpatient Record

 +1       ;global, ^XTMP("PSU_"_PSUJOB,"PSUIPV"

 +2       ;

 +3        SET T=0

           SET N=29

 +4        FOR 

               SET T=$ORDER(^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,T))

               IF 'T

                   QUIT 

               IF N=44

                   QUIT 

               Begin DoDot:1

 +5                SET PSUIDF=0

 +6                FOR 

                       SET PSUIDF=$ORDER(^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,T,PSUIDF))

                       IF 'PSUIDF

                           QUIT 

                       Begin DoDot:2

 +7                        SET $PIECE(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUC),U,N)=PSUIDF

 +8                        SET N=N+1

                       End DoDot:2

               End DoDot:1

 +9       ;

 +10       FOR N=29:1:44

               IF '$PIECE(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUC),U,N)

                   Begin DoDot:1

 +11      ;Set unfilled pieces to null

                       SET $PIECE(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUC),U,N)=""

                   End DoDot:1

 +12      ;Place "^" at end of record

           SET $PIECE(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUC),U,44)=""

 +13       QUIT