BKMVA1 ;PRXM/HC/CJS - HMS PATIENT REGISTER; [ 1/19/2005 7:16 PM ] ; 21 Jul 2005 12:25 PM
;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011
;
; Entry point will calculate reminders.
EN ; EP - Entry point for BKMV R/E Patient Record
N HIVIEN,BKMPRIV,BKMIEN,BKMREG,BKMTMP
S HIVIEN=$$HIVIEN^BKMIXX3()
I HIVIEN="" W !,"There is no HMS register defined." H 2 Q
I '$$VALID^BKMIXX3(DUZ) W !,"You are not a valid HMS user." H 2 Q
S BKMPRIV=$$BKMPRIV^BKMIXX3(DUZ)
;
K ^TMP("BKMVA1",$J)
F Q:'$$GETPAT^BKMVA1A() D
. S HIVIEN=$$HIVIEN^BKMIXX3()
. I HIVIEN="" W !,"There is no HMS register defined." H 2 Q
. S BKMPRIV=$$BKMPRIV^BKMIXX3(DUZ)
. ; Builds ^TMP("BKMLKP",$J) for patient info and sets DFN
. D BASETMP^BKMIXX3(DFN)
. S BKMIEN=$$BKMIEN^BKMIXX3(DFN)
. I BKMIEN="" W !,"There is no register entry for this patient." Q
. S BKMREG=$$BKMREG^BKMIXX3(BKMIEN)
. I BKMREG="" W !,"There is no HMS registry entry for this patient." Q
. ; Pre-edit audit capture
. D EN^BKMVAUD
. I BKMPRIV,$$MSNGDATA^BKMVA1A(DFN,HIVIEN),$$YNP^BKMVA1B("Do you want to add missing registry data at this time","NO") D D PROMPTS^BKMVA1B(DFN,1)
.. I $$EXISTHDC^BKMVA1A(DFN,HIVIEN),$$EXISTIHD^BKMVA1A(DFN,HIVIEN),$$EXISTIAD^BKMVA1A(DFN,HIVIEN) Q
.. D LDREC
. I $D(DIRUT) D POST^BKMVAUD Q
. I '$$GETALL(DFN,1) W !,"No Patient entered or Patient Not In Register" S BKMTMP=$$PAUSE^BKMIXX3 Q
. D ^XBFMK,EN^VALM("BKMV R/E PATIENT RECORD")
. K ^TMP("BKMVA1",$J)
. S:$G(DFN)="" DFN=$G(^TMP("BKMLKP",$J))
. S BKMIEN=$$BKMIEN^BKMIXX3(DFN)
. I BKMIEN="" W !,"There is no register entry for this patient." Q
. S BKMREG=$$BKMREG^BKMIXX3(BKMIEN)
. I BKMREG="" W !,"There is no HMS registry entry for this patient." Q
. ; Post-edit audit capture
. D ^XBFMK,POST^BKMVAUD
. K BKMVA1,BKMVA1E,DFN,X,Y,AGE,DOB,PNT,HRN,RID,ADD1,PHONE,RES,CRBY,CRDT,CRTM,EDBY,EDDT,EDTM,STAT,STATDT,STATCOM,ET
K BKMVA1,BKMVA1E,DFN,X,Y,AGE,DOB,PNT,HRN,RID,ADD1,PHONE,RES,CRBY,CRDT,CRTM,EDBY,EDDT,EDTM,STAT,STATDT,STATCOM,ET
K ^TMP("BKMVA2R",$J)
Q
;
EN2(DFN,AGE,SEX,DOB,PNT) ; EP - Main entry point for BKMV R/E Patient Record
N HIVIEN,BKMPRIV,BKMIEN,BKMREG,BKMTMP
S HIVIEN=$$HIVIEN^BKMIXX3()
I HIVIEN="" W !,"There is no HMS register defined." H 2 Q
I '$$VALID^BKMIXX3(DUZ) W !,"You are not a valid HMS user." Q
S BKMPRIV=$$BKMPRIV^BKMIXX3(DUZ)
;
K ^TMP("BKMVA1",$J)
; Builds ^TMP("BKMLKP",$J) for patient info and sets DFN
D BASETMP^BKMIXX3(DFN)
S BKMIEN=$$BKMIEN^BKMIXX3(DFN)
I BKMIEN="" W !,"There is no register entry for this patient." Q
S BKMREG=$$BKMREG^BKMIXX3(BKMIEN)
I BKMREG="" W !,"There is no HMS registry entry for this patient." Q
; Pre-edit audit capture
D EN^BKMVAUD
I BKMPRIV,$$MSNGDATA^BKMVA1A(DFN,HIVIEN),$$YNP^BKMVA1B("Do you want to add missing registry data at this time","NO") D D PROMPTS^BKMVA1B(DFN,1)
. I $$EXISTHDC^BKMVA1A(DFN,HIVIEN),$$EXISTIHD^BKMVA1A(DFN,HIVIEN),$$EXISTIAD^BKMVA1A(DFN,HIVIEN) Q
. D LDREC
I $D(DIRUT) D POST^BKMVAUD Q
;
I '$$GETALL(DFN,1) W !,"No Patient entered or Patient Not In Register" S BKMTMP=$$PAUSE^BKMIXX3 Q
D EN^VALM("BKMV R/E PATIENT RECORD")
K ^TMP("BKMVA1",$J)
S BKMIEN=$$BKMIEN^BKMIXX3(DFN)
I BKMIEN="" W !,"There is no register entry for this patient." Q
S BKMREG=$$BKMREG^BKMIXX3(BKMIEN)
I BKMREG="" W !,"There is no HMS registry entry for this patient." Q
; Post-edit audit capture
D POST^BKMVAUD
K BKMVA1,BKMVA1E,DFN,X,Y,AGE,DOB,PNT,HRN,RID,ADD1,PHONE,RES,CRBY,CRDT,CRTM,EDBY,EDDT,EDTM,STAT,STATDT,STATCOM
K ^TMP("BKMVA2R",$J)
Q
;
EN3 ; -- main entry point for BKMV R/E Patient Record. The Following entry point will not calculate reminders.
K BKMVA1,BKMVA1E,DFN,X,Y,AGE,DOB,PNT,HRN,RID,ADD1,PHONE,RES,CRBY,CRDT,CRTM,EDBY,EDDT,EDTM,STAT,STATDT,STATCOM
N HIVIEN,BKMPRIV,BKMIEN,BKMREG,BKMTMP
S HIVIEN=$$HIVIEN^BKMIXX3()
I HIVIEN="" W !,"There is no HMS register defined." H 2 Q
I '$$VALID^BKMIXX3(DUZ) W !,"You are not a valid HMS user." Q
S BKMPRIV=$$BKMPRIV^BKMIXX3(DUZ)
;
K ^TMP("BKMVA1",$J)
F Q:'$$GETPAT^BKMVA1A() D
. S HIVIEN=$$HIVIEN^BKMIXX3()
. I HIVIEN="" W !,"There is no HMS register defined." H 2 Q
. S BKMPRIV=$$BKMPRIV^BKMIXX3(DUZ)
. ; Builds ^TMP("BKMLKP",$J) for patient info and sets DFN
. D BASETMP^BKMIXX3(DFN)
. S BKMIEN=$$BKMIEN^BKMIXX3(DFN)
. I BKMIEN="" W !,"There is no register entry for this patient." Q
. S BKMREG=$$BKMREG^BKMIXX3(BKMIEN)
. I BKMREG="" W !,"There is no HMS registry entry for this patient." Q
. ; Pre-edit audit capture
. D EN^BKMVAUD
. I BKMPRIV,$$MSNGDATA^BKMVA1A(DFN,HIVIEN),$$YNP^BKMVA1B("Do you want to add missing registry data at this time","NO") D D PROMPTS^BKMVA1B(DFN,1)
.. I $$EXISTHDC^BKMVA1A(DFN,HIVIEN),$$EXISTIHD^BKMVA1A(DFN,HIVIEN),$$EXISTIAD^BKMVA1A(DFN,HIVIEN) Q
.. D LDREC
. I $D(DIRUT) D POST^BKMVAUD Q
. I '$$GETALL(DFN,0) W !,"No Patient entered or Patient Not In Register" S BKMTMP=$$PAUSE^BKMIXX3 Q
. D EN^VALM("BKMV R/E PATIENT RECORD")
. K ^TMP("BKMVA1",$J)
. S:$G(DFN)="" DFN=$G(^TMP("BKMLKP",$J))
. S BKMIEN=$$BKMIEN^BKMIXX3(DFN)
. I BKMIEN="" W !,"There is no register entry for this patient." Q
. S BKMREG=$$BKMREG^BKMIXX3(BKMIEN)
. I BKMREG="" W !,"There is no HMS registry entry for this patient." Q
. ; Post-edit audit capture
. D POST^BKMVAUD
. K BKMVA1,BKMVA1E,DFN,X,Y,AGE,DOB,PNT,HRN,RID,ADD1,PHONE,RES,CRBY,CRDT,CRTM,EDBY,EDDT,EDTM,STAT,STATDT,STATCOM
K BKMVA1,BKMVA1E,DFN,X,Y,AGE,DOB,PNT,HRN,RID,ADD1,PHONE,RES,CRBY,CRDT,CRTM,EDBY,EDDT,EDTM,STAT,STATDT,STATCOM
Q
;
HDR ; -- header code
N SITE,DA,IENS
S DA=$G(DUZ(2)),IENS=$$IENS^DILF(.DA),SITE=$$GET1^DIQ(4,IENS,.01,"E")
S VALMHDR(1)=$$PAD^BKMIXX4("",">"," ",(80-$L(SITE)+2)\2)_"["_$G(SITE)_"]"
Q
ADDRESS(DFN) ;EP
N ADDR,IND,FIELD,FIELDE,ITEM
S ADDR=""
F IND=.111,.112,.113,.114,.115,.116 D
. S ITEM=$$GET1^DIQ(2,DFN,IND,"E")
. I IND=".115" S ITEM=$$IENTOST(ITEM)
. I ADDR="" S ADDR=ITEM Q
. S ADDR=ADDR_"^"_ITEM Q
Q ADDR
IENTOEMP(IEN) ;
N EMPE,EMP
Q:IEN?." " ""
S EMP=$$GET1^DIQ(200,IEN,.01,"I","","EMPE")
Q:$D(EMPE) IEN
Q EMP
IENTOST(IEN) ;
N ST,STE
Q:IEN?." " ""
S ST=$$GET1^DIQ(5,IEN,1,"I","","STE")
Q:$D(STE) IEN
Q ST
PHONE(DFN,TYPE) ;EP
N PHONE,PHONEE
Q:DFN?." " ""
I '$D(TYPE) S TYPE=1
D GETS^DIQ(2,DFN,".131;.132","I","PHONE","PHONEE")
Q:$D(PHONEE) DFN
Q $S(TYPE=1:$G(PHONE(2,DFN_",",.131,"I")),TYPE=2:$G(PHONE(2,DFN_",",.132,"I")),1:"")
RES(DFN) ;EP
Q $$GET1^DIQ(9000001,DFN,"1117","E")
HRN(DFN) ;EP
N DA,IENS
S DA(1)=DFN,DA=DUZ(2)
S IENS=$$IENS^DILF(.DA)
Q $$GET1^DIQ(9000001.41,IENS,.02,"E")
PRIMPROV(DFN) ;EP
Q $$GET1^DIQ(9000001,DFN,.14,"E")
SUMMARY ; Health Summary
;D HS^BKMIHSM(DFN)
D SUPP^BKMSUPP(DFN)
S VALMBCK="R"
Q
; View/Edit problem list
UPD1HDR(SCRN,NAME) ;
S SCRN=$G(SCRN),NAME=$G(NAME)
W:SCRN'?." " !,SCRN
W:NAME'?." " !,NAME
W:SCRN'?." "!(NAME'?." ") !
Q
;
; Patient Reports in the patient record screen.
REPORTS ;
N EXITREP,SELECT,OPT
S EXITREP=0
F D Q:EXITREP
. D ^XBFMK
. D CLEAR^VALM1
. D FULL^VALM1
. ; PRXM/HC/BHS - 05/10/2006 - Replace DIR selector with code to allow
. ; partial matches on code and desc
. ;K DIR
. ;S DIR(0)="SO^DO:Due/OverDue;QC:Quality of Care Audit Report;SUPP:HMS Supplement;HS:Health Summary;BOTH:Both Health Summary and Supplement;SSR:State Surveillance Report;Q:Quit"
. ;S DIR("A")="Select Patient Report"
. ;D ^DIR
. ;S SELECT=Y
. ;I SELECT?." "!(SELECT?1."^")!(SELECT="Q") S EXITREP=1 Q
. S SELECT=$$OPT^BKMVA1C()
. I SELECT="" S EXITREP=1 Q
. I SELECT="DO" D ONE^BKMVDOD(DFN) Q
. ;I SELECT="2" D CSEL^BKMIMRP1 Q
. I SELECT="QC" D EN^BKMVQCR(1) Q
. I SELECT="SUPP" S OPT=1 D CLEAR^VALM1,FR2^BKMSUPP Q
. I SELECT="HS" S OPT=2 D CLEAR^VALM1,FR2^BKMSUPP Q
. I SELECT="BOTH" S OPT=3 D CLEAR^VALM1,FR2^BKMSUPP Q
. ;I $F("^3^4^5^",U_SELECT_U) S OPT=SELECT-2 D CLEAR^VALM1,FR1^BKMSUPP
. I SELECT="SSR" D EN1^BKMVSSR Q
. W !,"Invalid Entry"
D ^XBFMK
Q
;
ADDDATA(DFN) ;EP - Add Patient Data
K CALCREM
D ADDDATA^BKMVA2(DFN)
Q
INIT ;EP - Review/Edit Patient Record
D INIT^BKMVA2
Q
GETALL(DFN,RECALC) ;EP
S RECALC=$G(RECALC)
Q $$GETALL^BKMVA2(DFN,RECALC)
;
FREVEDIT(ADD,REV,PCCSF) ; EP - Review Edit
N OPTION
F Q:'$$REVEDIT(.OPTION) D
. I OPTION="ADD" D Q
. . ; PRXM/BHS - 04/05/2006 - Kill removed since it is inside the loop and would reset potentially after data was added for a previous iteration
. . ;K CALCREM
. . I '$G(BKMPRIV) D NOGO^BKMIXX3 Q
. . NEW DIR
. . S DIR(0)="YA"
. . S DIR("A")="Do you wish to continue? "
. . S DIR("A",1)="The data you enter for the above patient will be added permanently"
. . S DIR("A",2)="to the PCC database."
. . S DIR("A",3)=" "
. . S DIR("B")="YES"
. . D ^DIR
. . I $D(DTOUT)!$D(DUOUT)!(Y=0) Q
. . D @ADD
. . ; Save HMS PCC Buffer subfile
. . D SAVEVF^BKMVA1A(DFN,PCCSF)
. . ; PRXM/BHS - 04/05/2006 - Set CALCREM in SAVEVF^BKMVA1A only if data was actually saved
. . ;S CALCREM=1
. I OPTION="REV" D @REV Q
; Save HMS PCC Buffer subfile
;D SAVEVF^BKMVA1A(DFN,PCCSF)
Q
;
REVEDIT(OPTION) ;
N RCRDHDR,BKMDOD
D ^XBFMK
D CLEAR^VALM1
D FULL^VALM1
S RCRDHDR=$$PAD^BKMIXX4(" Patient: ",">"," ",10)_$$PAD^BKMIXX4($$GET1^DIQ(2,DFN,".01","E"),">"," ",30)_$$PAD^BKMIXX4(" HRN: ",">"," ",6)_$$PAD^BKMIXX4($$HRN^BKMVA1(DFN),">"," ",9)
S BKMDOD=$$GET1^DIQ(2,DFN,".351","I")
I BKMDOD'="" S RCRDHDR=RCRDHDR_$$PAD^BKMIXX4(" DOD: ",">"," ",6)_$$PAD^BKMIXX4($$FMTE^XLFDT(BKMDOD,1),">"," ",15)
W !,RCRDHDR
K DIR
S DIR(0)="SO^REV:Review History;ADD:Add New Data;Q:Quit"
;PRXM/HC/DLS 11/30/2005 ; changed V-File prompt to 'Select Action'...
S DIR("A")="Select Action"
;S DIR("A")="Select V-File Option"
D ^DIR I $D(DIRUT) D ^XBFMK Q 0
S OPTION=Y
I Y?1."^"!(Y?." ")!($TR($E(Y,1),"q","Q")="Q") D ^XBFMK Q 0
D ^XBFMK
Q 1
;
INFO ;
;N EXIT,INFO
;S EXIT=0
;F D Q:EXIT
;. D ^XBFMK
;. D CLEAR^VALM1
;. D FULL^VALM1
;. K DIR
;. S DIR(0)="SO^1:Enter/Edit Info;2:Print Info;Q:Quit;"
;. S DIR("A")="Select Info Option"
;. D ^DIR
;. S INFO=$G(Y)
;. I INFO?1."^"!(INFO?." ") S EXIT=1 Q
;.;PRXM/HC/CJS 07/21/2005 -- Check for edit access
;.; I INFO=1 D ^BKMDOCE Q
;. I INFO=1 D:$G(BKMPRIV) ^BKMDOCE D:'$G(BKMPRIV) NOGO^BKMIXX3 Q
;. I INFO=2 D ^BKMPHPR Q
;. I INFO="Q" S EXIT=1 Q
;. W !,"Invalid Selection"
;D ^XBFMK
Q
;
LDREC ;Load default values if Diagnosis Category is not at risk
N DIAG
S DIAG=$$DIAG^BKMVA1B(DFN)
I DIAG]"",'$F("^A^H^",U_DIAG_U) Q
D LDREC^BKMVA1B(DFN)
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !
Q
BKMVA1 ;PRXM/HC/CJS - HMS PATIENT REGISTER; [ 1/19/2005 7:16 PM ] ; 21 Jul 2005 12:25 PM
+1 ;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011
+2 ;
+3 ; Entry point will calculate reminders.
EN ; EP - Entry point for BKMV R/E Patient Record
+1 NEW HIVIEN,BKMPRIV,BKMIEN,BKMREG,BKMTMP
+2 SET HIVIEN=$$HIVIEN^BKMIXX3()
+3 IF HIVIEN=""
WRITE !,"There is no HMS register defined."
HANG 2
QUIT
+4 IF '$$VALID^BKMIXX3(DUZ)
WRITE !,"You are not a valid HMS user."
HANG 2
QUIT
+5 SET BKMPRIV=$$BKMPRIV^BKMIXX3(DUZ)
+6 ;
+7 KILL ^TMP("BKMVA1",$JOB)
+8 FOR
IF '$$GETPAT^BKMVA1A()
QUIT
Begin DoDot:1
+9 SET HIVIEN=$$HIVIEN^BKMIXX3()
+10 IF HIVIEN=""
WRITE !,"There is no HMS register defined."
HANG 2
QUIT
+11 SET BKMPRIV=$$BKMPRIV^BKMIXX3(DUZ)
+12 ; Builds ^TMP("BKMLKP",$J) for patient info and sets DFN
+13 DO BASETMP^BKMIXX3(DFN)
+14 SET BKMIEN=$$BKMIEN^BKMIXX3(DFN)
+15 IF BKMIEN=""
WRITE !,"There is no register entry for this patient."
QUIT
+16 SET BKMREG=$$BKMREG^BKMIXX3(BKMIEN)
+17 IF BKMREG=""
WRITE !,"There is no HMS registry entry for this patient."
QUIT
+18 ; Pre-edit audit capture
+19 DO EN^BKMVAUD
+20 IF BKMPRIV
IF $$MSNGDATA^BKMVA1A(DFN,HIVIEN)
IF $$YNP^BKMVA1B("Do you want to add missing registry data at this time","NO")
Begin DoDot:2
+21 IF $$EXISTHDC^BKMVA1A(DFN,HIVIEN)
IF $$EXISTIHD^BKMVA1A(DFN,HIVIEN)
IF $$EXISTIAD^BKMVA1A(DFN,HIVIEN)
QUIT
+22 DO LDREC
End DoDot:2
DO PROMPTS^BKMVA1B(DFN,1)
+23 IF $DATA(DIRUT)
DO POST^BKMVAUD
QUIT
+24 IF '$$GETALL(DFN,1)
WRITE !,"No Patient entered or Patient Not In Register"
SET BKMTMP=$$PAUSE^BKMIXX3
QUIT
+25 DO ^XBFMK
DO EN^VALM("BKMV R/E PATIENT RECORD")
+26 KILL ^TMP("BKMVA1",$JOB)
+27 IF $GET(DFN)=""
SET DFN=$GET(^TMP("BKMLKP",$JOB))
+28 SET BKMIEN=$$BKMIEN^BKMIXX3(DFN)
+29 IF BKMIEN=""
WRITE !,"There is no register entry for this patient."
QUIT
+30 SET BKMREG=$$BKMREG^BKMIXX3(BKMIEN)
+31 IF BKMREG=""
WRITE !,"There is no HMS registry entry for this patient."
QUIT
+32 ; Post-edit audit capture
+33 DO ^XBFMK
DO POST^BKMVAUD
+34 KILL BKMVA1,BKMVA1E,DFN,X,Y,AGE,DOB,PNT,HRN,RID,ADD1,PHONE,RES,CRBY,CRDT,CRTM,EDBY,EDDT,EDTM,STAT,STATDT,STATCOM,ET
End DoDot:1
+35 KILL BKMVA1,BKMVA1E,DFN,X,Y,AGE,DOB,PNT,HRN,RID,ADD1,PHONE,RES,CRBY,CRDT,CRTM,EDBY,EDDT,EDTM,STAT,STATDT,STATCOM,ET
+36 KILL ^TMP("BKMVA2R",$JOB)
+37 QUIT
+38 ;
EN2(DFN,AGE,SEX,DOB,PNT) ; EP - Main entry point for BKMV R/E Patient Record
+1 NEW HIVIEN,BKMPRIV,BKMIEN,BKMREG,BKMTMP
+2 SET HIVIEN=$$HIVIEN^BKMIXX3()
+3 IF HIVIEN=""
WRITE !,"There is no HMS register defined."
HANG 2
QUIT
+4 IF '$$VALID^BKMIXX3(DUZ)
WRITE !,"You are not a valid HMS user."
QUIT
+5 SET BKMPRIV=$$BKMPRIV^BKMIXX3(DUZ)
+6 ;
+7 KILL ^TMP("BKMVA1",$JOB)
+8 ; Builds ^TMP("BKMLKP",$J) for patient info and sets DFN
+9 DO BASETMP^BKMIXX3(DFN)
+10 SET BKMIEN=$$BKMIEN^BKMIXX3(DFN)
+11 IF BKMIEN=""
WRITE !,"There is no register entry for this patient."
QUIT
+12 SET BKMREG=$$BKMREG^BKMIXX3(BKMIEN)
+13 IF BKMREG=""
WRITE !,"There is no HMS registry entry for this patient."
QUIT
+14 ; Pre-edit audit capture
+15 DO EN^BKMVAUD
+16 IF BKMPRIV
IF $$MSNGDATA^BKMVA1A(DFN,HIVIEN)
IF $$YNP^BKMVA1B("Do you want to add missing registry data at this time","NO")
Begin DoDot:1
+17 IF $$EXISTHDC^BKMVA1A(DFN,HIVIEN)
IF $$EXISTIHD^BKMVA1A(DFN,HIVIEN)
IF $$EXISTIAD^BKMVA1A(DFN,HIVIEN)
QUIT
+18 DO LDREC
End DoDot:1
DO PROMPTS^BKMVA1B(DFN,1)
+19 IF $DATA(DIRUT)
DO POST^BKMVAUD
QUIT
+20 ;
+21 IF '$$GETALL(DFN,1)
WRITE !,"No Patient entered or Patient Not In Register"
SET BKMTMP=$$PAUSE^BKMIXX3
QUIT
+22 DO EN^VALM("BKMV R/E PATIENT RECORD")
+23 KILL ^TMP("BKMVA1",$JOB)
+24 SET BKMIEN=$$BKMIEN^BKMIXX3(DFN)
+25 IF BKMIEN=""
WRITE !,"There is no register entry for this patient."
QUIT
+26 SET BKMREG=$$BKMREG^BKMIXX3(BKMIEN)
+27 IF BKMREG=""
WRITE !,"There is no HMS registry entry for this patient."
QUIT
+28 ; Post-edit audit capture
+29 DO POST^BKMVAUD
+30 KILL BKMVA1,BKMVA1E,DFN,X,Y,AGE,DOB,PNT,HRN,RID,ADD1,PHONE,RES,CRBY,CRDT,CRTM,EDBY,EDDT,EDTM,STAT,STATDT,STATCOM
+31 KILL ^TMP("BKMVA2R",$JOB)
+32 QUIT
+33 ;
EN3 ; -- main entry point for BKMV R/E Patient Record. The Following entry point will not calculate reminders.
+1 KILL BKMVA1,BKMVA1E,DFN,X,Y,AGE,DOB,PNT,HRN,RID,ADD1,PHONE,RES,CRBY,CRDT,CRTM,EDBY,EDDT,EDTM,STAT,STATDT,STATCOM
+2 NEW HIVIEN,BKMPRIV,BKMIEN,BKMREG,BKMTMP
+3 SET HIVIEN=$$HIVIEN^BKMIXX3()
+4 IF HIVIEN=""
WRITE !,"There is no HMS register defined."
HANG 2
QUIT
+5 IF '$$VALID^BKMIXX3(DUZ)
WRITE !,"You are not a valid HMS user."
QUIT
+6 SET BKMPRIV=$$BKMPRIV^BKMIXX3(DUZ)
+7 ;
+8 KILL ^TMP("BKMVA1",$JOB)
+9 FOR
IF '$$GETPAT^BKMVA1A()
QUIT
Begin DoDot:1
+10 SET HIVIEN=$$HIVIEN^BKMIXX3()
+11 IF HIVIEN=""
WRITE !,"There is no HMS register defined."
HANG 2
QUIT
+12 SET BKMPRIV=$$BKMPRIV^BKMIXX3(DUZ)
+13 ; Builds ^TMP("BKMLKP",$J) for patient info and sets DFN
+14 DO BASETMP^BKMIXX3(DFN)
+15 SET BKMIEN=$$BKMIEN^BKMIXX3(DFN)
+16 IF BKMIEN=""
WRITE !,"There is no register entry for this patient."
QUIT
+17 SET BKMREG=$$BKMREG^BKMIXX3(BKMIEN)
+18 IF BKMREG=""
WRITE !,"There is no HMS registry entry for this patient."
QUIT
+19 ; Pre-edit audit capture
+20 DO EN^BKMVAUD
+21 IF BKMPRIV
IF $$MSNGDATA^BKMVA1A(DFN,HIVIEN)
IF $$YNP^BKMVA1B("Do you want to add missing registry data at this time","NO")
Begin DoDot:2
+22 IF $$EXISTHDC^BKMVA1A(DFN,HIVIEN)
IF $$EXISTIHD^BKMVA1A(DFN,HIVIEN)
IF $$EXISTIAD^BKMVA1A(DFN,HIVIEN)
QUIT
+23 DO LDREC
End DoDot:2
DO PROMPTS^BKMVA1B(DFN,1)
+24 IF $DATA(DIRUT)
DO POST^BKMVAUD
QUIT
+25 IF '$$GETALL(DFN,0)
WRITE !,"No Patient entered or Patient Not In Register"
SET BKMTMP=$$PAUSE^BKMIXX3
QUIT
+26 DO EN^VALM("BKMV R/E PATIENT RECORD")
+27 KILL ^TMP("BKMVA1",$JOB)
+28 IF $GET(DFN)=""
SET DFN=$GET(^TMP("BKMLKP",$JOB))
+29 SET BKMIEN=$$BKMIEN^BKMIXX3(DFN)
+30 IF BKMIEN=""
WRITE !,"There is no register entry for this patient."
QUIT
+31 SET BKMREG=$$BKMREG^BKMIXX3(BKMIEN)
+32 IF BKMREG=""
WRITE !,"There is no HMS registry entry for this patient."
QUIT
+33 ; Post-edit audit capture
+34 DO POST^BKMVAUD
+35 KILL BKMVA1,BKMVA1E,DFN,X,Y,AGE,DOB,PNT,HRN,RID,ADD1,PHONE,RES,CRBY,CRDT,CRTM,EDBY,EDDT,EDTM,STAT,STATDT,STATCOM
End DoDot:1
+36 KILL BKMVA1,BKMVA1E,DFN,X,Y,AGE,DOB,PNT,HRN,RID,ADD1,PHONE,RES,CRBY,CRDT,CRTM,EDBY,EDDT,EDTM,STAT,STATDT,STATCOM
+37 QUIT
+38 ;
HDR ; -- header code
+1 NEW SITE,DA,IENS
+2 SET DA=$GET(DUZ(2))
SET IENS=$$IENS^DILF(.DA)
SET SITE=$$GET1^DIQ(4,IENS,.01,"E")
+3 SET VALMHDR(1)=$$PAD^BKMIXX4("",">"," ",(80-$LENGTH(SITE)+2)\2)_"["_$GET(SITE)_"]"
+4 QUIT
ADDRESS(DFN) ;EP
+1 NEW ADDR,IND,FIELD,FIELDE,ITEM
+2 SET ADDR=""
+3 FOR IND=.111,.112,.113,.114,.115,.116
Begin DoDot:1
+4 SET ITEM=$$GET1^DIQ(2,DFN,IND,"E")
+5 IF IND=".115"
SET ITEM=$$IENTOST(ITEM)
+6 IF ADDR=""
SET ADDR=ITEM
QUIT
+7 SET ADDR=ADDR_"^"_ITEM
QUIT
End DoDot:1
+8 QUIT ADDR
IENTOEMP(IEN) ;
+1 NEW EMPE,EMP
+2 IF IEN?." "
QUIT ""
+3 SET EMP=$$GET1^DIQ(200,IEN,.01,"I","","EMPE")
+4 IF $DATA(EMPE)
QUIT IEN
+5 QUIT EMP
IENTOST(IEN) ;
+1 NEW ST,STE
+2 IF IEN?." "
QUIT ""
+3 SET ST=$$GET1^DIQ(5,IEN,1,"I","","STE")
+4 IF $DATA(STE)
QUIT IEN
+5 QUIT ST
PHONE(DFN,TYPE) ;EP
+1 NEW PHONE,PHONEE
+2 IF DFN?." "
QUIT ""
+3 IF '$DATA(TYPE)
SET TYPE=1
+4 DO GETS^DIQ(2,DFN,".131;.132","I","PHONE","PHONEE")
+5 IF $DATA(PHONEE)
QUIT DFN
+6 QUIT $SELECT(TYPE=1:$GET(PHONE(2,DFN_",",.131,"I")),TYPE=2:$GET(PHONE(2,DFN_",",.132,"I")),1:"")
RES(DFN) ;EP
+1 QUIT $$GET1^DIQ(9000001,DFN,"1117","E")
HRN(DFN) ;EP
+1 NEW DA,IENS
+2 SET DA(1)=DFN
SET DA=DUZ(2)
+3 SET IENS=$$IENS^DILF(.DA)
+4 QUIT $$GET1^DIQ(9000001.41,IENS,.02,"E")
PRIMPROV(DFN) ;EP
+1 QUIT $$GET1^DIQ(9000001,DFN,.14,"E")
SUMMARY ; Health Summary
+1 ;D HS^BKMIHSM(DFN)
+2 DO SUPP^BKMSUPP(DFN)
+3 SET VALMBCK="R"
+4 QUIT
+5 ; View/Edit problem list
UPD1HDR(SCRN,NAME) ;
+1 SET SCRN=$GET(SCRN)
SET NAME=$GET(NAME)
+2 IF SCRN'?." "
WRITE !,SCRN
+3 IF NAME'?." "
WRITE !,NAME
+4 IF SCRN'?." "!(NAME'?." ")
WRITE !
+5 QUIT
+6 ;
+7 ; Patient Reports in the patient record screen.
REPORTS ;
+1 NEW EXITREP,SELECT,OPT
+2 SET EXITREP=0
+3 FOR
Begin DoDot:1
+4 DO ^XBFMK
+5 DO CLEAR^VALM1
+6 DO FULL^VALM1
+7 ; PRXM/HC/BHS - 05/10/2006 - Replace DIR selector with code to allow
+8 ; partial matches on code and desc
+9 ;K DIR
+10 ;S DIR(0)="SO^DO:Due/OverDue;QC:Quality of Care Audit Report;SUPP:HMS Supplement;HS:Health Summary;BOTH:Both Health Summary and Supplement;SSR:State Surveillance Report;Q:Quit"
+11 ;S DIR("A")="Select Patient Report"
+12 ;D ^DIR
+13 ;S SELECT=Y
+14 ;I SELECT?." "!(SELECT?1."^")!(SELECT="Q") S EXITREP=1 Q
+15 SET SELECT=$$OPT^BKMVA1C()
+16 IF SELECT=""
SET EXITREP=1
QUIT
+17 IF SELECT="DO"
DO ONE^BKMVDOD(DFN)
QUIT
+18 ;I SELECT="2" D CSEL^BKMIMRP1 Q
+19 IF SELECT="QC"
DO EN^BKMVQCR(1)
QUIT
+20 IF SELECT="SUPP"
SET OPT=1
DO CLEAR^VALM1
DO FR2^BKMSUPP
QUIT
+21 IF SELECT="HS"
SET OPT=2
DO CLEAR^VALM1
DO FR2^BKMSUPP
QUIT
+22 IF SELECT="BOTH"
SET OPT=3
DO CLEAR^VALM1
DO FR2^BKMSUPP
QUIT
+23 ;I $F("^3^4^5^",U_SELECT_U) S OPT=SELECT-2 D CLEAR^VALM1,FR1^BKMSUPP
+24 IF SELECT="SSR"
DO EN1^BKMVSSR
QUIT
+25 WRITE !,"Invalid Entry"
End DoDot:1
IF EXITREP
QUIT
+26 DO ^XBFMK
+27 QUIT
+28 ;
ADDDATA(DFN) ;EP - Add Patient Data
+1 KILL CALCREM
+2 DO ADDDATA^BKMVA2(DFN)
+3 QUIT
INIT ;EP - Review/Edit Patient Record
+1 DO INIT^BKMVA2
+2 QUIT
GETALL(DFN,RECALC) ;EP
+1 SET RECALC=$GET(RECALC)
+2 QUIT $$GETALL^BKMVA2(DFN,RECALC)
+3 ;
FREVEDIT(ADD,REV,PCCSF) ; EP - Review Edit
+1 NEW OPTION
+2 FOR
IF '$$REVEDIT(.OPTION)
QUIT
Begin DoDot:1
+3 IF OPTION="ADD"
Begin DoDot:2
+4 ; PRXM/BHS - 04/05/2006 - Kill removed since it is inside the loop and would reset potentially after data was added for a previous iteration
+5 ;K CALCREM
+6 IF '$GET(BKMPRIV)
DO NOGO^BKMIXX3
QUIT
+7 NEW DIR
+8 SET DIR(0)="YA"
+9 SET DIR("A")="Do you wish to continue? "
+10 SET DIR("A",1)="The data you enter for the above patient will be added permanently"
+11 SET DIR("A",2)="to the PCC database."
+12 SET DIR("A",3)=" "
+13 SET DIR("B")="YES"
+14 DO ^DIR
+15 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y=0)
QUIT
+16 DO @ADD
+17 ; Save HMS PCC Buffer subfile
+18 DO SAVEVF^BKMVA1A(DFN,PCCSF)
+19 ; PRXM/BHS - 04/05/2006 - Set CALCREM in SAVEVF^BKMVA1A only if data was actually saved
+20 ;S CALCREM=1
End DoDot:2
QUIT
+21 IF OPTION="REV"
DO @REV
QUIT
End DoDot:1
+22 ; Save HMS PCC Buffer subfile
+23 ;D SAVEVF^BKMVA1A(DFN,PCCSF)
+24 QUIT
+25 ;
REVEDIT(OPTION) ;
+1 NEW RCRDHDR,BKMDOD
+2 DO ^XBFMK
+3 DO CLEAR^VALM1
+4 DO FULL^VALM1
+5 SET RCRDHDR=$$PAD^BKMIXX4(" Patient: ",">"," ",10)_$$PAD^BKMIXX4($$GET1^DIQ(2,DFN,".01","E"),">"," ",30)_$$PAD^BKMIXX4(" HRN: ",">"," ",6)_$$PAD^BKMIXX4($$HRN^BKMVA1(DFN),">"," ",9)
+6 SET BKMDOD=$$GET1^DIQ(2,DFN,".351","I")
+7 IF BKMDOD'=""
SET RCRDHDR=RCRDHDR_$$PAD^BKMIXX4(" DOD: ",">"," ",6)_$$PAD^BKMIXX4($$FMTE^XLFDT(BKMDOD,1),">"," ",15)
+8 WRITE !,RCRDHDR
+9 KILL DIR
+10 SET DIR(0)="SO^REV:Review History;ADD:Add New Data;Q:Quit"
+11 ;PRXM/HC/DLS 11/30/2005 ; changed V-File prompt to 'Select Action'...
+12 SET DIR("A")="Select Action"
+13 ;S DIR("A")="Select V-File Option"
+14 DO ^DIR
IF $DATA(DIRUT)
DO ^XBFMK
QUIT 0
+15 SET OPTION=Y
+16 IF Y?1."^"!(Y?." ")!($TRANSLATE($EXTRACT(Y,1),"q","Q")="Q")
DO ^XBFMK
QUIT 0
+17 DO ^XBFMK
+18 QUIT 1
+19 ;
INFO ;
+1 ;N EXIT,INFO
+2 ;S EXIT=0
+3 ;F D Q:EXIT
+4 ;. D ^XBFMK
+5 ;. D CLEAR^VALM1
+6 ;. D FULL^VALM1
+7 ;. K DIR
+8 ;. S DIR(0)="SO^1:Enter/Edit Info;2:Print Info;Q:Quit;"
+9 ;. S DIR("A")="Select Info Option"
+10 ;. D ^DIR
+11 ;. S INFO=$G(Y)
+12 ;. I INFO?1."^"!(INFO?." ") S EXIT=1 Q
+13 ;.;PRXM/HC/CJS 07/21/2005 -- Check for edit access
+14 ;.; I INFO=1 D ^BKMDOCE Q
+15 ;. I INFO=1 D:$G(BKMPRIV) ^BKMDOCE D:'$G(BKMPRIV) NOGO^BKMIXX3 Q
+16 ;. I INFO=2 D ^BKMPHPR Q
+17 ;. I INFO="Q" S EXIT=1 Q
+18 ;. W !,"Invalid Selection"
+19 ;D ^XBFMK
+20 QUIT
+21 ;
LDREC ;Load default values if Diagnosis Category is not at risk
+1 NEW DIAG
+2 SET DIAG=$$DIAG^BKMVA1B(DFN)
+3 IF DIAG]""
IF '$FIND("^A^H^",U_DIAG_U)
QUIT
+4 DO LDREC^BKMVA1B(DFN)
+5 QUIT
+6 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !
+2 QUIT
