Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSUDEM9

PSUDEM9.m

Go to the documentation of this file. 
  1. PSUDEM9 ;BIR/DAM - CPT Codes for Inpatient PTF Record Extract ;20 DEC 2001
  1.  ;;4.0;PHARMACY BENEFITS MANAGEMENT;**19**;MARCH, 2005;Build 28
  1.  ;
  1.  ;DBIA's
  1.  ; Reference to file 45         supported by DBIA 3511
  1.  ; Reference to ICDEX           supported by DBIA 5747
  1.  ;
  1. EN ;EN      Called from PSUDEM8
  1.  K PSUCSYS,SCOUNT S SCOUNT=0   ; code system marker  "9","10",or "U"
  1.  D CPTP
  1.  D P
  1.  D AO
  1.  D FIN
  1.  K PSUCSYS,SCOUNT
  1.  ;
  1.  Q
  1.  ;
  1. CPTP ;Find CPT pointers for the ^DGPT(D0,"401P" node by $ ordering
  1.  ;through the ^DGPT(D0,"AP",Pointer) cross reference
  1.  ;
  1.  S I=17
  1.  S PSUAP=0
  1.  F  S PSUAP=$O(^DGPT(PSUC,"AP",PSUAP)) Q:PSUAP=""  Q:SCOUNT>15  D
  1.  .N PSUCPT
  1.  .S PSUCPT=$$ICDOP^ICDEX(PSUAP,,,"I")
  1.  .S:+PSUCPT>0 PSUCSYS(PSUC,$P(PSUCPT,U,15))="",PSUCPT=$P(PSUCPT,U,2)   ;Set code system per CPT also
  1.  .I $G(PSUCPT)]"" S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,I,PSUCPT)=""    ;Set temp global
  1.  .S I=I+1,SCOUNT=SCOUNT+1
  1.  Q
  1.  ;
  1. 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
  1.  ;
  1.  S I=22
  1.  S PSUP=0
  1.  F  S PSUP=$O(^DGPT(PSUC,"P","AP6",PSUP)) Q:PSUP=""  Q:SCOUNT>15  D
  1.  .N PSUCPT
  1.  .S PSUCPT=$$ICDOP^ICDEX(PSUP,,,"I")
  1.  .S:+PSUCPT>0 PSUCSYS(PSUC,$P(PSUCPT,U,15))="",PSUCPT=$P(PSUCPT,U,2)
  1.  .I $G(PSUCPT)]"" S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,I,PSUCPT)=""    ;Set temp global
  1.  .D DEL
  1.  .S I=I+1,SCOUNT=SCOUNT+1
  1.  Q
  1.  ;
  1. DEL ;Delete duplicates
  1.  ;
  1.  F N=17:1:21 I $D(^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,N,PSUCPT)) D
  1.  .K ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,I,PSUCPT) S SCOUNT=SCOUNT-1
  1.  Q
  1.  ;
  1. 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
  1.  ;
  1.  S I=27
  1.  S PSUBP=0
  1.  F  S PSUBP=$O(^DGPT(PSUC,"S","AO",PSUBP)) Q:PSUBP=""  Q:SCOUNT>15  D
  1.  .N PSUCPT
  1.  .S PSUCPT=$$ICDOP^ICDEX(PSUBP,,,"I")
  1.  .S:+PSUCPT>0 PSUCSYS(PSUC,$P(PSUCPT,U,15))="",PSUCPT=$P(PSUCPT,U,2)
  1.  .I $G(PSUCPT)]"" S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,I,PSUCPT)=""    ;Set temp global
  1.  .D DEL1
  1.  .S I=I+1,SCOUNT=SCOUNT+1
  1.  Q
  1.  ;
  1. DEL1 ;Delete duplicates
  1.  ;
  1.  F N=17:1:26 I $D(^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,N,PSUCPT)) D
  1.  .K ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,I,PSUCPT) S SCOUNT=SCOUNT-1
  1.  Q
  1.  ;
  1. FIN ;$O through temp global, and set codes into the Inpatient Record
  1.  ;global, ^XTMP("PSU_"_PSUJOB,"PSUIPV"
  1.  ;
  1.  S T=0,N=28
  1.  F  S T=$O(^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,T)) Q:'T  Q:N=44  D
  1.  .S PSUIDF=0
  1.  .F  S PSUIDF=$O(^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,T,PSUIDF)) Q:'(PSUIDF]"")  D
  1.  ..S $P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUC),U,N)=PSUIDF
  1.  ..S N=N+1
  1.  ;
  1.  F N=28:1:44 I '($P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUC),U,N)]"") D
  1.  .S $P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUC),U,N)=""    ;Set unfilled pieces to null
  1.  S $P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUC),U,44)=""    ;Place "^" at end of record
  1.  ;
  1.  ; Place code system per record in  LAST "^"piece  =    "9","10","U"(both)
  1.  ;
  1.  S PSUCSYS=$G(PSUCSYS1,"")
  1.  I $D(PSUCSYS(PSUC,2)),$D(PSUCSYS(PSUC,31)) S PSUCSYS="U"
  1.  I $D(PSUCSYS(PSUC,2)),($G(PSUCSYS,"")'["U") S PSUCSYS=$S(+PSUCSYS=10:"U",1:"9")
  1.  I $D(PSUCSYS(PSUC,31)),($G(PSUCSYS,"")'["U") S PSUCSYS=$S(+PSUCSYS=9:"U",1:"10")
  1.  S $P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUC),U,$L(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUC),U))=PSUCSYS
  1.  K PSUCSYS1
  1.  Q