PSUDEM9 ;BIR/DAM - CPT Codes for Inpatient PTF Record Extract ;20 DEC 2001
;;4.0;PHARMACY BENEFITS MANAGEMENT;**19**;MARCH, 2005;Build 28
;
;DBIA's
; Reference to file 45 supported by DBIA 3511
; Reference to ICDEX supported by DBIA 5747
;
EN ;EN Called from PSUDEM8
K PSUCSYS,SCOUNT S SCOUNT=0 ; code system marker "9","10",or "U"
D CPTP
D P
D AO
D FIN
K PSUCSYS,SCOUNT
;
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="" Q:SCOUNT>15 D
.N PSUCPT
.S PSUCPT=$$ICDOP^ICDEX(PSUAP,,,"I")
.S:+PSUCPT>0 PSUCSYS(PSUC,$P(PSUCPT,U,15))="",PSUCPT=$P(PSUCPT,U,2) ;Set code system per CPT also
.I $G(PSUCPT)]"" S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,I,PSUCPT)="" ;Set temp global
.S I=I+1,SCOUNT=SCOUNT+1
Q
;
P ;Find CPT pointers for the ^DGPT(D0,"P" node by $O through
;the ^DGPT(D0,"P","AP6",pointer,D1) cross reference. ANY NUMBER
;
S I=22
S PSUP=0
F S PSUP=$O(^DGPT(PSUC,"P","AP6",PSUP)) Q:PSUP="" Q:SCOUNT>15 D
.N PSUCPT
.S PSUCPT=$$ICDOP^ICDEX(PSUP,,,"I")
.S:+PSUCPT>0 PSUCSYS(PSUC,$P(PSUCPT,U,15))="",PSUCPT=$P(PSUCPT,U,2)
.I $G(PSUCPT)]"" S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,I,PSUCPT)="" ;Set temp global
.D DEL
.S I=I+1,SCOUNT=SCOUNT+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) S SCOUNT=SCOUNT-1
Q
;
AO ;Find CPT pointers for the ^DGPT(D0,"P" node by $O through
;the ^DGPT(D0,"S","AO",pointer,D1) cross reference. ANY NUMBER
;
S I=27
S PSUBP=0
F S PSUBP=$O(^DGPT(PSUC,"S","AO",PSUBP)) Q:PSUBP="" Q:SCOUNT>15 D
.N PSUCPT
.S PSUCPT=$$ICDOP^ICDEX(PSUBP,,,"I")
.S:+PSUCPT>0 PSUCSYS(PSUC,$P(PSUCPT,U,15))="",PSUCPT=$P(PSUCPT,U,2)
.I $G(PSUCPT)]"" S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,I,PSUCPT)="" ;Set temp global
.D DEL1
.S I=I+1,SCOUNT=SCOUNT+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) S SCOUNT=SCOUNT-1
Q
;
FIN ;$O through temp global, and set codes into the Inpatient Record
;global, ^XTMP("PSU_"_PSUJOB,"PSUIPV"
;
S T=0,N=28
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=28: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
;
; Place code system per record in LAST "^"piece = "9","10","U"(both)
;
S PSUCSYS=$G(PSUCSYS1,"")
I $D(PSUCSYS(PSUC,2)),$D(PSUCSYS(PSUC,31)) S PSUCSYS="U"
I $D(PSUCSYS(PSUC,2)),($G(PSUCSYS,"")'["U") S PSUCSYS=$S(+PSUCSYS=10:"U",1:"9")
I $D(PSUCSYS(PSUC,31)),($G(PSUCSYS,"")'["U") S PSUCSYS=$S(+PSUCSYS=9:"U",1:"10")
S $P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUC),U,$L(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUC),U))=PSUCSYS
K PSUCSYS1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSUDEM9 3267 printed Dec 13, 2024@02:27:50 Page 2
PSUDEM9 ;BIR/DAM - CPT Codes for Inpatient PTF Record Extract ;20 DEC 2001
+1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**19**;MARCH, 2005;Build 28
+2 ;
+3 ;DBIA's
+4 ; Reference to file 45 supported by DBIA 3511
+5 ; Reference to ICDEX supported by DBIA 5747
+6 ;
EN ;EN Called from PSUDEM8
+1 ; code system marker "9","10",or "U"
KILL PSUCSYS,SCOUNT
SET SCOUNT=0
+2 DO CPTP
+3 DO P
+4 DO AO
+5 DO FIN
+6 KILL PSUCSYS,SCOUNT
+7 ;
+8 QUIT
+9 ;
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
if SCOUNT>15
QUIT
Begin DoDot:1
+6 NEW PSUCPT
+7 SET PSUCPT=$$ICDOP^ICDEX(PSUAP,,,"I")
+8 ;Set code system per CPT also
if +PSUCPT>0
SET PSUCSYS(PSUC,$PIECE(PSUCPT,U,15))=""
SET PSUCPT=$PIECE(PSUCPT,U,2)
+9 ;Set temp global
IF $GET(PSUCPT)]""
SET ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,I,PSUCPT)=""
+10 SET I=I+1
SET SCOUNT=SCOUNT+1
End DoDot:1
+11 QUIT
+12 ;
P ;Find CPT pointers for the ^DGPT(D0,"P" node by $O through
+1 ;the ^DGPT(D0,"P","AP6",pointer,D1) cross reference. ANY NUMBER
+2 ;
+3 SET I=22
+4 SET PSUP=0
+5 FOR
SET PSUP=$ORDER(^DGPT(PSUC,"P","AP6",PSUP))
if PSUP=""
QUIT
if SCOUNT>15
QUIT
Begin DoDot:1
+6 NEW PSUCPT
+7 SET PSUCPT=$$ICDOP^ICDEX(PSUP,,,"I")
+8 if +PSUCPT>0
SET PSUCSYS(PSUC,$PIECE(PSUCPT,U,15))=""
SET PSUCPT=$PIECE(PSUCPT,U,2)
+9 ;Set temp global
IF $GET(PSUCPT)]""
SET ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,I,PSUCPT)=""
+10 DO DEL
+11 SET I=I+1
SET SCOUNT=SCOUNT+1
End DoDot:1
+12 QUIT
+13 ;
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)
SET SCOUNT=SCOUNT-1
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. ANY NUMBER
+2 ;
+3 SET I=27
+4 SET PSUBP=0
+5 FOR
SET PSUBP=$ORDER(^DGPT(PSUC,"S","AO",PSUBP))
if PSUBP=""
QUIT
if SCOUNT>15
QUIT
Begin DoDot:1
+6 NEW PSUCPT
+7 SET PSUCPT=$$ICDOP^ICDEX(PSUBP,,,"I")
+8 if +PSUCPT>0
SET PSUCSYS(PSUC,$PIECE(PSUCPT,U,15))=""
SET PSUCPT=$PIECE(PSUCPT,U,2)
+9 ;Set temp global
IF $GET(PSUCPT)]""
SET ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,I,PSUCPT)=""
+10 DO DEL1
+11 SET I=I+1
SET SCOUNT=SCOUNT+1
End DoDot:1
+12 QUIT
+13 ;
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)
SET SCOUNT=SCOUNT-1
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=28
+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=28: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 ;
+14 ; Place code system per record in LAST "^"piece = "9","10","U"(both)
+15 ;
+16 SET PSUCSYS=$GET(PSUCSYS1,"")
+17 IF $DATA(PSUCSYS(PSUC,2))
IF $DATA(PSUCSYS(PSUC,31))
SET PSUCSYS="U"
+18 IF $DATA(PSUCSYS(PSUC,2))
IF ($GET(PSUCSYS,"")'["U")
SET PSUCSYS=$SELECT(+PSUCSYS=10:"U",1:"9")
+19 IF $DATA(PSUCSYS(PSUC,31))
IF ($GET(PSUCSYS,"")'["U")
SET PSUCSYS=$SELECT(+PSUCSYS=9:"U",1:"10")
+20 SET $PIECE(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUC),U,$LENGTH(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUC),U))=PSUCSYS
+21 KILL PSUCSYS1
+22 QUIT
