BWMPMAIN ;IHS/CIA/PLS - Main driver for Mammography Project Add/Edit ;01-Oct-2003 16:55;PLS
;;2.0;WOMEN'S HEALTH;**9**;04-Apr-2003 11:31
;=================================================================
EN D EN1
Q
; Main loop
EN1 ;
N X,BWQUIT
F Q:$$PATSEL=-1
Q
PATSEL() ;
D TITLE^BWUTL5("Add/Edit Mammography Project Data")
; PATSEL1() ;
N Y,BWDFN
W !!," Select the patient you wish to add or edit."
D PATLKUP^BWUTL8(.Y,"ADD")
Q:Y<0 -1
S BWDFN=+Y
D CDCID(BWDFN)
D ADDEDIT
Q 0
;
ADDEDIT ;
N DIR
S DIR(0)="SO^1:Add New Procedure;2:Edit Existing Procedure"
S DIR("A")="Which function"
W !
D ^DIR
I Y=1 D
.D ADD
E I Y=2 D
.D LOOKUP
Q
ADD ; Add a procedure
N DRSTR,BWPCDDA
S BWPCDN=$O(^BWPN("B","MAMMOGRAPHY PROJECT",0))
I 'BWPCDN D Q
.W !,"The MAMMOGRAPHY PROJECT procedure is missing."
.W !,"Contact the computer department."
I BWPCDN&($$GET1^DIQ(9002086.2,BWPCDN,.18,"I")=1) D Q
.I D
..W !,"The MAMMOGRAPHY PROJECT procedure is INACTIVE."
..W !,"Contact the site manager."
..S BWQUIT=1
D DATECHK^BWPROC Q:BWPOP
S BWACC=$$ACCSSN^BWUTL5(BWPCDN)
I BWACC']"" D Q
.W !!?5,*7,"Unable to generate accession number. Contact your site manager."
.S ERROR=-1 D DIRZ^BWUTL3
S DRSTR=".02////"_BWDFN_";.03////"_BWPCDT_";.04////"_BWPCDN_";.1////"_$G(DUZ(2))_";.12////"_BWPCDT_";.18////"_DUZ_";.19///"_$$DT^XLFDT_";.34////"_$G(DUZ(2))
D FILE^BWFMAN(9002086.1,DRSTR,"ML",BWACC,9002086,.BWPCDDA)
I BWPCDDA=-1 D Q
.W !!?5,*7,"Unable to create new procedure. Contact your site manager."
.S ERROR=-1 D DIRZ^BWUTL3
;
EDIT D SCREEN(+BWPCDDA)
Q
; Call ScreenMan interface engine
SCREEN(BWPCDDA) ;
N DR
S DR="[BW MP MAIN]"
D DDS^BWFMAN(9002086.1,DR,BWPCDDA,"","",.BWQUIT)
Q
LOOKUP ; Lookup existing Mammography Project procedure
N BWX,FLG
N D,DIC,Y,X
S (BWX,FLG)=0
F S BWX=$O(^BWPCD("C",BWDFN,BWX)) Q:'BWX!FLG D
.S:+$P($G(^BWPCD(BWX,0)),U,4)=44 FLG=1
I 'FLG D Q
.;W !,$$GET1^DIQ(2,BWDFN,.01,"E")," is not enrolled in the Mammography Project."
.;W !,"She will now be enrolled."
.D ADD
E D Q
.S D="C",DIC="^BWPCD(",DIC(0)="EQZ"
.S X=BWDFN,DIC("S")="I $P(^(0),U,4)=44"
.D IX^DIC
.D:Y>0 SCREEN(+Y)
Q
; Assign a CDCID # to this patient
CDCID(BWDFN) ;
N X
S X=$$CDCID^BWUTL5(BWDFN,DUZ(2))
Q:X']""
D DIE^BWFMAN(9002086,".2////"_X,BWDFN,.BWPOP)
Q
;
HELP Q
BWMPMAIN ;IHS/CIA/PLS - Main driver for Mammography Project Add/Edit ;01-Oct-2003 16:55;PLS
+1 ;;2.0;WOMEN'S HEALTH;**9**;04-Apr-2003 11:31
+2 ;=================================================================
EN DO EN1
+1 QUIT
+2 ; Main loop
EN1 ;
+1 NEW X,BWQUIT
+2 FOR
IF $$PATSEL=-1
QUIT
+3 QUIT
PATSEL() ;
+1 DO TITLE^BWUTL5("Add/Edit Mammography Project Data")
+2 ; PATSEL1() ;
+3 NEW Y,BWDFN
+4 WRITE !!," Select the patient you wish to add or edit."
+5 DO PATLKUP^BWUTL8(.Y,"ADD")
+6 IF Y<0
QUIT -1
+7 SET BWDFN=+Y
+8 DO CDCID(BWDFN)
+9 DO ADDEDIT
+10 QUIT 0
+11 ;
ADDEDIT ;
+1 NEW DIR
+2 SET DIR(0)="SO^1:Add New Procedure;2:Edit Existing Procedure"
+3 SET DIR("A")="Which function"
+4 WRITE !
+5 DO ^DIR
+6 IF Y=1
Begin DoDot:1
+7 DO ADD
End DoDot:1
+8 IF '$TEST
IF Y=2
Begin DoDot:1
+9 DO LOOKUP
End DoDot:1
+10 QUIT
ADD ; Add a procedure
+1 NEW DRSTR,BWPCDDA
+2 SET BWPCDN=$ORDER(^BWPN("B","MAMMOGRAPHY PROJECT",0))
+3 IF 'BWPCDN
Begin DoDot:1
+4 WRITE !,"The MAMMOGRAPHY PROJECT procedure is missing."
+5 WRITE !,"Contact the computer department."
End DoDot:1
QUIT
+6 IF BWPCDN&($$GET1^DIQ(9002086.2,BWPCDN,.18,"I")=1)
Begin DoDot:1
+7 IF $TEST
Begin DoDot:2
+8 WRITE !,"The MAMMOGRAPHY PROJECT procedure is INACTIVE."
+9 WRITE !,"Contact the site manager."
+10 SET BWQUIT=1
End DoDot:2
End DoDot:1
QUIT
+11 DO DATECHK^BWPROC
IF BWPOP
QUIT
+12 SET BWACC=$$ACCSSN^BWUTL5(BWPCDN)
+13 IF BWACC']""
Begin DoDot:1
+14 WRITE !!?5,*7,"Unable to generate accession number. Contact your site manager."
+15 SET ERROR=-1
DO DIRZ^BWUTL3
End DoDot:1
QUIT
+16 SET DRSTR=".02////"_BWDFN_";.03////"_BWPCDT_";.04////"_BWPCDN_";.1////"_$GET(DUZ(2))_";.12////"_BWPCDT_";.18////"_DUZ_";.19///"_$$DT^XLFDT_";.34////"_$G(DUZ(2))
+17 DO FILE^BWFMAN(9002086.1,DRSTR,"ML",BWACC,9002086,.BWPCDDA)
+18 IF BWPCDDA=-1
Begin DoDot:1
+19 WRITE !!?5,*7,"Unable to create new procedure. Contact your site manager."
+20 SET ERROR=-1
DO DIRZ^BWUTL3
End DoDot:1
QUIT
+21 ;
EDIT DO SCREEN(+BWPCDDA)
+1 QUIT
+2 ; Call ScreenMan interface engine
SCREEN(BWPCDDA) ;
+1 NEW DR
+2 SET DR="[BW MP MAIN]"
+3 DO DDS^BWFMAN(9002086.1,DR,BWPCDDA,"","",.BWQUIT)
+4 QUIT
LOOKUP ; Lookup existing Mammography Project procedure
+1 NEW BWX,FLG
+2 NEW D,DIC,Y,X
+3 SET (BWX,FLG)=0
+4 FOR
SET BWX=$ORDER(^BWPCD("C",BWDFN,BWX))
IF 'BWX!FLG
QUIT
Begin DoDot:1
+5 IF +$PIECE($GET(^BWPCD(BWX,0)),U,4)=44
SET FLG=1
End DoDot:1
+6 IF 'FLG
Begin DoDot:1
+7 ;W !,$$GET1^DIQ(2,BWDFN,.01,"E")," is not enrolled in the Mammography Project."
+8 ;W !,"She will now be enrolled."
+9 DO ADD
End DoDot:1
QUIT
+10 IF '$TEST
Begin DoDot:1
+11 SET D="C"
SET DIC="^BWPCD("
SET DIC(0)="EQZ"
+12 SET X=BWDFN
SET DIC("S")="I $P(^(0),U,4)=44"
+13 DO IX^DIC
+14 IF Y>0
DO SCREEN(+Y)
End DoDot:1
QUIT
+15 QUIT
+16 ; Assign a CDCID # to this patient
CDCID(BWDFN) ;
+1 NEW X
+2 SET X=$$CDCID^BWUTL5(BWDFN,DUZ(2))
+3 IF X']""
QUIT
+4 DO DIE^BWFMAN(9002086,".2////"_X,BWDFN,.BWPOP)
+5 QUIT
+6 ;
HELP QUIT
