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

BW2P13IN.m

Go to the documentation of this file.
  1. BW2P13IN ;GDIT/HS/ALA-Installation routine ; 19 Mar 2014 11:36 AM
  1. ;;2.0;WOMEN'S HEALTH;**13**;APR 19, 1996;Build 9
  1. ;
  1. PRE ;EP
  1. NEW CMN,BN,BWUP,TEXT
  1. F TEXT="CONE BIOPSY","CRYOTHERAPY","ECTOCERVICAL BIOPSY","ENDOCERVICAL CURETTAGE","ENDOMETRIAL BIOPSY","NEEDLE BIOPSY" D UPD(TEXT,TEXT)
  1. D UPD("MASTECTOMY,UNSPECIFIED","MASTECTOMY")
  1. Q
  1. ;
  1. UPD(TEXT,TEXT1) ;EP
  1. S CMN=$O(^BTPW(90621,"B",TEXT,"")) I CMN="" Q
  1. I $P(^BTPW(90621,CMN,0),U,5)="" D
  1. . S BN=$O(^BWPN("B",TEXT1,"")) I BN="" Q
  1. . S BWUP(90621,CMN_",",.05)=BN
  1. I $D(BWUP) D FILE^DIE("","BWUP","ERROR")
  1. Q
  1. ;
  1. POS ;EP
  1. ;
  1. NEW BN,OK,TEXT,VALUE,CMN,TN,TAX,CPT
  1. S BN=$O(^BWPN("B","CLINICAL BREAST EXAM",""))
  1. I BN'="" D
  1. . S BWUP(9002086.2,BN_",",.12)="9000010.18",BWUP(9002086.2,BN_",",.16)="@"
  1. . S VAL=$O(^ICPT("BA","S0613 ",""))
  1. . I VAL'="" S BWUP(9002086.2,BN_",",.08)=VAL
  1. S BN=0
  1. F S BN=$O(^BWPN(BN)) Q:'BN D
  1. . I $P(^BWPN(BN,0),U,12)'="9000010.08" Q
  1. . S OK=0
  1. . F I=1:1 S TEXT=$P($T(PR+I),";;",2) Q:TEXT="" I $P(TEXT,U,1)=$P(^BWPN(BN,0),U,1) S OK=1,VALUE=TEXT
  1. . I OK D Q
  1. .. I $P(VALUE,U,2)="" Q
  1. .. S BWUP(9002086.2,BN_",",.12)="9000010.18",BWUP(9002086.2,BN_",",.08)=$P(VALUE,U,2),BWUP(9002086.2,BN_",",.14)="@"
  1. . I 'OK D
  1. .. S CMN=$O(^BTPW(90621,"AP",BN,"")) I CMN="" Q
  1. .. S TN=0 F S TN=$O(^BTPW(90621,CMN,1,TN)) Q:'TN D
  1. ... I $P(^BTPW(90621,CMN,1,TN,0),U,3)'=5 Q
  1. ... S TAX=$P(^BTPW(90621,CMN,1,TN,0),U,1),REF="BWTAX" K @REF
  1. ... D BLD^BQITUTL(TAX,.REF)
  1. ... S CPT=$O(BWTAX(CPT)) Q:CPT="" I $P(^ICPT(CPT,0),U,7)="",$P(^ICPT(CPT,0),U,8)<DT S BWUP(9002086.2,BN_",",.08)=CPT Q
  1. ... S BWUP(9002086.2,BN_",",.12)="9000010.18",BWUP(9002086.2,BN_",",.14)="@"
  1. I $D(BWUP) D FILE^DIE("","BWUP","ERROR")
  1. Q
  1. ;
  1. PR ;EP Procedures
  1. ;;COLPOSCOPY IMPRESSION (NO BX)^57452
  1. ;;COLPOSCOPY W/BIOPSY^57454
  1. ;;CONE BIOPSY^57520
  1. ;;CRYOTHERAPY^57061
  1. ;;ECTOCERVICAL BIOPSY^57500
  1. ;;ENDOCERVICAL CURRETTAGE^57505
  1. ;;ENDOMETRIAL BIOPSY^58100
  1. ;;FINE NEEDLE ASPIRATION^10021
  1. ;;HYSTERECTOMY^58150
  1. ;;LASER ABLATION^58353
  1. ;;LASER CONE^57522
  1. ;;LEEP^57460
  1. ;;LUMPECTOMY^19301
  1. ;;MASTECTOMY^19303
  1. ;;NEEDLE BIOPSY^19100
  1. ;;OPEN BIOPSY^19101