- 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