BWPATE ;IHS/ANMC/MWR/CIA/PLS - PATIENT CASE DATA EDIT;23-Jan-2009 10:35;DU
;;2.0;WOMEN'S HEALTH;**8,9,11,13**;APR 19, 1996;Build 9
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; CALLED BY OPTION: "BW EDIT PATIENT CASE DATA".
;
D SETVARS^BWUTL5
F D PATIENT Q:BWPOP
;
EXIT ;EP
D KILLALL^BWUTL8
Q
;
;
PATIENT ;EP
D TITLE^BWUTL5("EDIT PATIENT CASE DATA")
PATIENT1 ;EP
;---> TO AVOID @IOF AND TITLE.
;---> SELECT PATIENT.
N Y
W !!," Select the patient you wish to add or edit."
D PATLKUP^BWUTL8(.Y,"ADD")
I Y<0 S BWPOP=1 Q
S BWDFN=+Y
D CDCID(BWDFN)
D SCREEN(BWDFN) S BWPOP=0
Q
;
;
SCREEN(BWDFN) ;EP
;---> EDIT PATIENT CASE DATA WITH SCREENMAN.
;---> REQUIRED VARIABLES: BWDFN=DFN OF PATIENT.
N DR
S DR="[BW PATIENT-FORM-1]"
D DDS^BWFMAN(9002086,DR,BWDFN,"","",.BWPOP)
Q:BWPOP
N DIR W !,"Do you wish to PRINT this patient's Case Data?"
S DIR(0)="Y",DIR("B")="NO" D ^DIR K DIR W !
D:Y PRTCASE^BWPATP(BWDFN)
Q
;
CASEDATA(BWDFN) ;EP
;---> CALLED AFTER ADD/EDIT OF NOTIFICATIONS.
N DIR W !,"Do you wish to EDIT this patient's Case Data?"
S DIR("?",1)=" Enter YES to edit this patient's Case Manager, "
S DIR("?")=" PAP Regimen, Current Need, etc."
S DIR(0)="Y",DIR("B")="NO" D ^DIR K DIR W !
D:Y SCREEN(BWDFN)
Q
;
AUTOADD(DFN,SITE,Y,BWPRMT) ;EP
;---> AUTOMATIC ADD OF A NEW PATIENT TO "BW PATIENT FILE".
;---> SET CASEMANAGER TO SITE PARAMETER DEFAULT.
;---> SET PAP TX NEED (#.11), PAP REGIMEN (#.16)="Undetermined",
;---> MAM TX NEED (#.18)="Undetermined".
;---> Set RACE of patient via tribal affiliation
;---> PARAMETERS:
; 1 - DFN (REQUIRED) IEN OF PATIENT IN ^AUPNPAT(
; 2 - SITE (REQUIRED) DUZ(2) FOR DEFAULT CASE MANAGER
; 3 - Y (RETURNED) FROM ^DICN: IEN OR -1 FAILURE TO ADD PT
; 4 - BWPRMT (OPTIONAL) EQUALS 1 IF PROMPT WHEN FAILURE
;
S (DINUM,X)=DFN
;---> SET CASE MANAGER DEFAULT.
N BWCMGR,DIC
S BWCMGR=$S($D(SITE):$P(^BWSITE(SITE,0),U,2),1:"")
S:'$G(BWPRMT) BWPRMT=0
;S DIC("DR")=".1////"_BWCMGR_";.11///Undetermined;.16///Undetermined"
;S DIC("DR")=DIC("DR")_";.18///Undetermined"
;S DIC("DR")=DIC("DR")_";.2////"_$$CDCID^BWUTL5(DFN,SITE)_";.21////"_DT
K DD,DO S DIC="^BWP(",DIC(0)="ML",DLAYGO=9002086
D FILE^DICN K DIC
;---> IF Y<0, CHECK PERMISSIONS.
I Y<0,BWPRMT D Q
.W !!?5,"* UNABLE to add this patient to the Women's Health database."
.W !?5," Please contact your site manager to check permissions."
.D DIRZ^BWUTL3
S Y=+Y
S BWUP(9002086,Y_",",.1)=BWCMGR,BWUP(9002086,Y_",",.11)="Undetermined"
S BWUP(9002086,Y_",",.16)="Undetermined",BWUP(9002086,Y_",",.18)="Undetermined"
S BWUP(9002086,Y_",",.2)=$$CDCID^BWUTL5(DFN,SITE),BWUP(9002086,Y_",",.21)=DT
D FILE^DIE("","BWUP","ERROR")
D ADDRACE(DFN,Y)
Q
;
CDCID(BWDFN) ;EP
;---> ASSIGN A CDCID# TO THIS PATIENT.
N X S X=$$CDCID^BWUTL5(BWDFN,DUZ(2))
Q:X']""
D DIE^BWFMAN(9002086,".2////"_X,BWDFN,.BWPOP)
Q
;
CDCEDIT ;EP
;---> EDIT A PATIENT'S CDC ID NUMBER.
D SETVARS^BWUTL5
N Y
F D Q:$G(Y)<0
.D TITLE^BWUTL5("EDIT A PATIENT'S CDC ID NUMBER")
.D PATLKUP^BWUTL8(.Y)
.Q:Y<0
.D DIE^BWFMAN(9002086,.2,+Y,.BWPOP)
.S:BWPOP Y=-1
Q
; Return Previous Procedure Date of type passed or None
PREVPROC(BWPROC,BWDFN,BWDT) ;
N X
S BWDT=$G(BWDT,DT)
S X=$G(^BWPCD($$FINDLAST^BWMDEX2(BWPROC,BWDT,0),0))
Q $S($P(X,U,12):$$FMTE^XLFDT($P(X,U,12)),1:"None") ;"5Z"
; Add Race associated with tribal affiliation
; (defaults to American Indian
ADDRACE(BWDFN,IEN) ;
N BWIENS,BWFDA,BWERR,BWRC
S IENS="+1,"_IEN_","
S BWRC=$$GET1^DIQ(9000001,BWDFN,1108,"I")
S BWRC=+$O(^BWRACE("C",BWRC,0))
S:'BWRC BWRC=""
S BWFDA(9002086.07,IENS,.001)=1
S BWFDA(9002086.07,IENS,.01)=BWRC
D UPDATE^DIE("","BWFDA","","BWERR")
Q
; Screen on Race Field in BW PATIENT File
; Returns availability of race entry for selection
RACESEL(IEN) ;
N MDEVER
S MDEVER=+$$GET1^DIQ(9002086.02,+$G(DUZ(2)),.18,"I")
Q +$O(^BWRACE(IEN,1,"AC",MDEVER,0))>0
BWPATE ;IHS/ANMC/MWR/CIA/PLS - PATIENT CASE DATA EDIT;23-Jan-2009 10:35;DU
+1 ;;2.0;WOMEN'S HEALTH;**8,9,11,13**;APR 19, 1996;Build 9
+2 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+3 ;; CALLED BY OPTION: "BW EDIT PATIENT CASE DATA".
+4 ;
+5 DO SETVARS^BWUTL5
+6 FOR
DO PATIENT
IF BWPOP
QUIT
+7 ;
EXIT ;EP
+1 DO KILLALL^BWUTL8
+2 QUIT
+3 ;
+4 ;
PATIENT ;EP
+1 DO TITLE^BWUTL5("EDIT PATIENT CASE DATA")
PATIENT1 ;EP
+1 ;---> TO AVOID @IOF AND TITLE.
+2 ;---> SELECT PATIENT.
+3 NEW Y
+4 WRITE !!," Select the patient you wish to add or edit."
+5 DO PATLKUP^BWUTL8(.Y,"ADD")
+6 IF Y<0
SET BWPOP=1
QUIT
+7 SET BWDFN=+Y
+8 DO CDCID(BWDFN)
+9 DO SCREEN(BWDFN)
SET BWPOP=0
+10 QUIT
+11 ;
+12 ;
SCREEN(BWDFN) ;EP
+1 ;---> EDIT PATIENT CASE DATA WITH SCREENMAN.
+2 ;---> REQUIRED VARIABLES: BWDFN=DFN OF PATIENT.
+3 NEW DR
+4 SET DR="[BW PATIENT-FORM-1]"
+5 DO DDS^BWFMAN(9002086,DR,BWDFN,"","",.BWPOP)
+6 IF BWPOP
QUIT
+7 NEW DIR
WRITE !,"Do you wish to PRINT this patient's Case Data?"
+8 SET DIR(0)="Y"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
WRITE !
+9 IF Y
DO PRTCASE^BWPATP(BWDFN)
+10 QUIT
+11 ;
CASEDATA(BWDFN) ;EP
+1 ;---> CALLED AFTER ADD/EDIT OF NOTIFICATIONS.
+2 NEW DIR
WRITE !,"Do you wish to EDIT this patient's Case Data?"
+3 SET DIR("?",1)=" Enter YES to edit this patient's Case Manager, "
+4 SET DIR("?")=" PAP Regimen, Current Need, etc."
+5 SET DIR(0)="Y"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
WRITE !
+6 IF Y
DO SCREEN(BWDFN)
+7 QUIT
+8 ;
AUTOADD(DFN,SITE,Y,BWPRMT) ;EP
+1 ;---> AUTOMATIC ADD OF A NEW PATIENT TO "BW PATIENT FILE".
+2 ;---> SET CASEMANAGER TO SITE PARAMETER DEFAULT.
+3 ;---> SET PAP TX NEED (#.11), PAP REGIMEN (#.16)="Undetermined",
+4 ;---> MAM TX NEED (#.18)="Undetermined".
+5 ;---> Set RACE of patient via tribal affiliation
+6 ;---> PARAMETERS:
+7 ; 1 - DFN (REQUIRED) IEN OF PATIENT IN ^AUPNPAT(
+8 ; 2 - SITE (REQUIRED) DUZ(2) FOR DEFAULT CASE MANAGER
+9 ; 3 - Y (RETURNED) FROM ^DICN: IEN OR -1 FAILURE TO ADD PT
+10 ; 4 - BWPRMT (OPTIONAL) EQUALS 1 IF PROMPT WHEN FAILURE
+11 ;
+12 SET (DINUM,X)=DFN
+13 ;---> SET CASE MANAGER DEFAULT.
+14 NEW BWCMGR,DIC
+15 SET BWCMGR=$SELECT($DATA(SITE):$PIECE(^BWSITE(SITE,0),U,2),1:"")
+16 IF '$GET(BWPRMT)
SET BWPRMT=0
+17 ;S DIC("DR")=".1////"_BWCMGR_";.11///Undetermined;.16///Undetermined"
+18 ;S DIC("DR")=DIC("DR")_";.18///Undetermined"
+19 ;S DIC("DR")=DIC("DR")_";.2////"_$$CDCID^BWUTL5(DFN,SITE)_";.21////"_DT
+20 KILL DD,DO
SET DIC="^BWP("
SET DIC(0)="ML"
SET DLAYGO=9002086
+21 DO FILE^DICN
KILL DIC
+22 ;---> IF Y<0, CHECK PERMISSIONS.
+23 IF Y<0
IF BWPRMT
Begin DoDot:1
+24 WRITE !!?5,"* UNABLE to add this patient to the Women's Health database."
+25 WRITE !?5," Please contact your site manager to check permissions."
+26 DO DIRZ^BWUTL3
End DoDot:1
QUIT
+27 SET Y=+Y
+28 SET BWUP(9002086,Y_",",.1)=BWCMGR
SET BWUP(9002086,Y_",",.11)="Undetermined"
+29 SET BWUP(9002086,Y_",",.16)="Undetermined"
SET BWUP(9002086,Y_",",.18)="Undetermined"
+30 SET BWUP(9002086,Y_",",.2)=$$CDCID^BWUTL5(DFN,SITE)
SET BWUP(9002086,Y_",",.21)=DT
+31 DO FILE^DIE("","BWUP","ERROR")
+32 DO ADDRACE(DFN,Y)
+33 QUIT
+34 ;
CDCID(BWDFN) ;EP
+1 ;---> ASSIGN A CDCID# TO THIS PATIENT.
+2 NEW X
SET X=$$CDCID^BWUTL5(BWDFN,DUZ(2))
+3 IF X']""
QUIT
+4 DO DIE^BWFMAN(9002086,".2////"_X,BWDFN,.BWPOP)
+5 QUIT
+6 ;
CDCEDIT ;EP
+1 ;---> EDIT A PATIENT'S CDC ID NUMBER.
+2 DO SETVARS^BWUTL5
+3 NEW Y
+4 FOR
Begin DoDot:1
+5 DO TITLE^BWUTL5("EDIT A PATIENT'S CDC ID NUMBER")
+6 DO PATLKUP^BWUTL8(.Y)
+7 IF Y<0
QUIT
+8 DO DIE^BWFMAN(9002086,.2,+Y,.BWPOP)
+9 IF BWPOP
SET Y=-1
End DoDot:1
IF $GET(Y)<0
QUIT
+10 QUIT
+11 ; Return Previous Procedure Date of type passed or None
PREVPROC(BWPROC,BWDFN,BWDT) ;
+1 NEW X
+2 SET BWDT=$GET(BWDT,DT)
+3 SET X=$GET(^BWPCD($$FINDLAST^BWMDEX2(BWPROC,BWDT,0),0))
+4 ;"5Z"
QUIT $SELECT($PIECE(X,U,12):$$FMTE^XLFDT($PIECE(X,U,12)),1:"None")
+5 ; Add Race associated with tribal affiliation
+6 ; (defaults to American Indian
ADDRACE(BWDFN,IEN) ;
+1 NEW BWIENS,BWFDA,BWERR,BWRC
+2 SET IENS="+1,"_IEN_","
+3 SET BWRC=$$GET1^DIQ(9000001,BWDFN,1108,"I")
+4 SET BWRC=+$ORDER(^BWRACE("C",BWRC,0))
+5 IF 'BWRC
SET BWRC=""
+6 SET BWFDA(9002086.07,IENS,.001)=1
+7 SET BWFDA(9002086.07,IENS,.01)=BWRC
+8 DO UPDATE^DIE("","BWFDA","","BWERR")
+9 QUIT
+10 ; Screen on Race Field in BW PATIENT File
+11 ; Returns availability of race entry for selection
RACESEL(IEN) ;
+1 NEW MDEVER
+2 SET MDEVER=+$$GET1^DIQ(9002086.02,+$GET(DUZ(2)),.18,"I")
+3 QUIT +$ORDER(^BWRACE(IEN,1,"AC",MDEVER,0))>0
