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
