- BW2P13IN ;GDIT/HS/ALA-Installation routine ; 19 Mar 2014 11:36 AM
- ;;2.0;WOMEN'S HEALTH;**13**;APR 19, 1996;Build 9
- ;
- PRE ;EP
- NEW CMN,BN,BWUP,TEXT
- F TEXT="CONE BIOPSY","CRYOTHERAPY","ECTOCERVICAL BIOPSY","ENDOCERVICAL CURETTAGE","ENDOMETRIAL BIOPSY","NEEDLE BIOPSY" D UPD(TEXT,TEXT)
- D UPD("MASTECTOMY,UNSPECIFIED","MASTECTOMY")
- Q
- ;
- UPD(TEXT,TEXT1) ;EP
- S CMN=$O(^BTPW(90621,"B",TEXT,"")) I CMN="" Q
- I $P(^BTPW(90621,CMN,0),U,5)="" D
- . S BN=$O(^BWPN("B",TEXT1,"")) I BN="" Q
- . S BWUP(90621,CMN_",",.05)=BN
- I $D(BWUP) D FILE^DIE("","BWUP","ERROR")
- Q
- ;
- POS ;EP
- ;
- NEW BN,OK,TEXT,VALUE,CMN,TN,TAX,CPT
- S BN=$O(^BWPN("B","CLINICAL BREAST EXAM",""))
- I BN'="" D
- . S BWUP(9002086.2,BN_",",.12)="9000010.18",BWUP(9002086.2,BN_",",.16)="@"
- . S VAL=$O(^ICPT("BA","S0613 ",""))
- . I VAL'="" S BWUP(9002086.2,BN_",",.08)=VAL
- S BN=0
- F S BN=$O(^BWPN(BN)) Q:'BN D
- . I $P(^BWPN(BN,0),U,12)'="9000010.08" Q
- . S OK=0
- . 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
- . I OK D Q
- .. I $P(VALUE,U,2)="" Q
- .. S BWUP(9002086.2,BN_",",.12)="9000010.18",BWUP(9002086.2,BN_",",.08)=$P(VALUE,U,2),BWUP(9002086.2,BN_",",.14)="@"
- . I 'OK D
- .. S CMN=$O(^BTPW(90621,"AP",BN,"")) I CMN="" Q
- .. S TN=0 F S TN=$O(^BTPW(90621,CMN,1,TN)) Q:'TN D
- ... I $P(^BTPW(90621,CMN,1,TN,0),U,3)'=5 Q
- ... S TAX=$P(^BTPW(90621,CMN,1,TN,0),U,1),REF="BWTAX" K @REF
- ... D BLD^BQITUTL(TAX,.REF)
- ... 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
- ... S BWUP(9002086.2,BN_",",.12)="9000010.18",BWUP(9002086.2,BN_",",.14)="@"
- I $D(BWUP) D FILE^DIE("","BWUP","ERROR")
- Q
- ;
- PR ;EP Procedures
- ;;COLPOSCOPY IMPRESSION (NO BX)^57452
- ;;COLPOSCOPY W/BIOPSY^57454
- ;;CONE BIOPSY^57520
- ;;CRYOTHERAPY^57061
- ;;ECTOCERVICAL BIOPSY^57500
- ;;ENDOCERVICAL CURRETTAGE^57505
- ;;ENDOMETRIAL BIOPSY^58100
- ;;FINE NEEDLE ASPIRATION^10021
- ;;HYSTERECTOMY^58150
- ;;LASER ABLATION^58353
- ;;LASER CONE^57522
- ;;LEEP^57460
- ;;LUMPECTOMY^19301
- ;;MASTECTOMY^19303
- ;;NEEDLE BIOPSY^19100
- ;;OPEN BIOPSY^19101
- BW2P13IN ;GDIT/HS/ALA-Installation routine ; 19 Mar 2014 11:36 AM
- +1 ;;2.0;WOMEN'S HEALTH;**13**;APR 19, 1996;Build 9
- +2 ;
- PRE ;EP
- +1 NEW CMN,BN,BWUP,TEXT
- +2 FOR TEXT="CONE BIOPSY","CRYOTHERAPY","ECTOCERVICAL BIOPSY","ENDOCERVICAL CURETTAGE","ENDOMETRIAL BIOPSY","NEEDLE BIOPSY"
- DO UPD(TEXT,TEXT)
- +3 DO UPD("MASTECTOMY,UNSPECIFIED","MASTECTOMY")
- +4 QUIT
- +5 ;
- UPD(TEXT,TEXT1) ;EP
- +1 SET CMN=$ORDER(^BTPW(90621,"B",TEXT,""))
- IF CMN=""
- QUIT
- +2 IF $PIECE(^BTPW(90621,CMN,0),U,5)=""
- Begin DoDot:1
- +3 SET BN=$ORDER(^BWPN("B",TEXT1,""))
- IF BN=""
- QUIT
- +4 SET BWUP(90621,CMN_",",.05)=BN
- End DoDot:1
- +5 IF $DATA(BWUP)
- DO FILE^DIE("","BWUP","ERROR")
- +6 QUIT
- +7 ;
- POS ;EP
- +1 ;
- +2 NEW BN,OK,TEXT,VALUE,CMN,TN,TAX,CPT
- +3 SET BN=$ORDER(^BWPN("B","CLINICAL BREAST EXAM",""))
- +4 IF BN'=""
- Begin DoDot:1
- +5 SET BWUP(9002086.2,BN_",",.12)="9000010.18"
- SET BWUP(9002086.2,BN_",",.16)="@"
- +6 SET VAL=$ORDER(^ICPT("BA","S0613 ",""))
- +7 IF VAL'=""
- SET BWUP(9002086.2,BN_",",.08)=VAL
- End DoDot:1
- +8 SET BN=0
- +9 FOR
- SET BN=$ORDER(^BWPN(BN))
- IF 'BN
- QUIT
- Begin DoDot:1
- +10 IF $PIECE(^BWPN(BN,0),U,12)'="9000010.08"
- QUIT
- +11 SET OK=0
- +12 FOR I=1:1
- SET TEXT=$PIECE($TEXT(PR+I),";;",2)
- IF TEXT=""
- QUIT
- IF $PIECE(TEXT,U,1)=$PIECE(^BWPN(BN,0),U,1)
- SET OK=1
- SET VALUE=TEXT
- +13 IF OK
- Begin DoDot:2
- +14 IF $PIECE(VALUE,U,2)=""
- QUIT
- +15 SET BWUP(9002086.2,BN_",",.12)="9000010.18"
- SET BWUP(9002086.2,BN_",",.08)=$PIECE(VALUE,U,2)
- SET BWUP(9002086.2,BN_",",.14)="@"
- End DoDot:2
- QUIT
- +16 IF 'OK
- Begin DoDot:2
- +17 SET CMN=$ORDER(^BTPW(90621,"AP",BN,""))
- IF CMN=""
- QUIT
- +18 SET TN=0
- FOR
- SET TN=$ORDER(^BTPW(90621,CMN,1,TN))
- IF 'TN
- QUIT
- Begin DoDot:3
- +19 IF $PIECE(^BTPW(90621,CMN,1,TN,0),U,3)'=5
- QUIT
- +20 SET TAX=$PIECE(^BTPW(90621,CMN,1,TN,0),U,1)
- SET REF="BWTAX"
- KILL @REF
- +21 DO BLD^BQITUTL(TAX,.REF)
- +22 SET CPT=$ORDER(BWTAX(CPT))
- IF CPT=""
- QUIT
- IF $PIECE(^ICPT(CPT,0),U,7)=""
- IF $PIECE(^ICPT(CPT,0),U,8)<DT
- SET BWUP(9002086.2,BN_",",.08)=CPT
- QUIT
- +23 SET BWUP(9002086.2,BN_",",.12)="9000010.18"
- SET BWUP(9002086.2,BN_",",.14)="@"
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +24 IF $DATA(BWUP)
- DO FILE^DIE("","BWUP","ERROR")
- +25 QUIT
- +26 ;
- PR ;EP Procedures
- +1 ;;COLPOSCOPY IMPRESSION (NO BX)^57452
- +2 ;;COLPOSCOPY W/BIOPSY^57454
- +3 ;;CONE BIOPSY^57520
- +4 ;;CRYOTHERAPY^57061
- +5 ;;ECTOCERVICAL BIOPSY^57500
- +6 ;;ENDOCERVICAL CURRETTAGE^57505
- +7 ;;ENDOMETRIAL BIOPSY^58100
- +8 ;;FINE NEEDLE ASPIRATION^10021
- +9 ;;HYSTERECTOMY^58150
- +10 ;;LASER ABLATION^58353
- +11 ;;LASER CONE^57522
- +12 ;;LEEP^57460
- +13 ;;LUMPECTOMY^19301
- +14 ;;MASTECTOMY^19303
- +15 ;;NEEDLE BIOPSY^19100
- +16 ;;OPEN BIOPSY^19101