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
