BKMVF1 ;PRXM/HC/JGH - Manually Add Patient To Register ; 17 Jul 2005 1:31 PM
;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011
QUIT
PROMPT ;Prompt user for Patient
NEW DFN,ADD,REGISTER,PATIENT,STATUS,OPTPAR,OPTS,OPTA,YN
S REGISTER=$$HIVIEN^BKMIXX3()
I REGISTER="" D EN^DDIOL("There is no HMS register defined.") H 2 Q
;
; The following line no longer applies
;I '$D(^BKM(90450,REGISTER,11,"B",DUZ)) D EN^DDIOL("You are not a valid HMS user.") H 2 Q
;
F Q:'$$GETPAT(.DFN) D
. S ENTRY=$O(^BKM(90451,"B",DFN,""))
. I ENTRY'="",$D(^BKM(90451,"D",REGISTER,ENTRY)) W !!,PNT,": is already in the register.",!! Q
. S STATUS="R"
. I $$GETOCCUP(DUZ)="M" S STATUS=$$STATUS ; Only File Managers are able to change the status.
. I STATUS="^"!(STATUS="") W !!,"The patient wasn't added to the register." Q
. S DIAGCAT=$$DIAG^BKMIXX3() I DIAGCAT=-1 S DIAGCAT="^"
. I DIAGCAT="^"!(DIAGCAT="") W !!,"The patient wasn't added to the register." Q
. S DIAGSTAT=""
. I DIAGCAT="H"!(DIAGCAT="A") S DIAGSTAT=$$CLINCLAS I DIAGSTAT="^"!(DIAGSTAT="") W !!,"The patient wasn't added to the register." Q
. S OPTA="Add the selected patient to the HMS register",OPTS=""
. S OPTPAR="Y"
. S YN=$$PROMPT2^BKMIXX4(OPTPAR,.OPTS,OPTA) I YN<1!(YN["^") W !!,"The patient wasn't added to the register." Q
. D ADD(DFN,STATUS)
. I $$BASETMP^BKMIXX3(DFN) D EN^VALM("BKMV R/E PATIENT RECORD",)
. W @IOF,"The patient has been added to the register.",!! H 2
K DIAGCAT,DIAGSTAT
QUIT
ADD(DFN,STATUS) ; add the patient to the register with status of "R" (unreviewed)
NEW BKMIEN,BKMREG
D ^XBFMK ; Kills off a lot of Fileman variables
S BKMIEN=$O(^BKM(90451,"B",DFN,"")) ; BKMIEN and BKMREG are used by the routine BKMVAUD
I BKMIEN="" D ADDENT(DFN) S BKMIEN=$O(^BKM(90451,"B",DFN,"")) ; Create entry in ICare registry for patient.
I BKMIEN="" W !,"Error, An entry for "_ADD(DFN)_" wasn't created in HMS." Q ; end audit log
S BKMREG=$O(^BKM(90451,BKMIEN,1,"B",REGISTER,""))
I BKMREG="" D ADDTOREG(REGISTER,BKMIEN) S BKMREG=$O(^BKM(90451,BKMIEN,1,"B",REGISTER,""))
I BKMREG="" W !,"Error, An entry for "_ADD(DFN)_" wasn't created in HMS." Q ; end audit log
;
; Enter audit entry for the NEW record
D NEW^BKMVAUDN(BKMIEN,BKMREG,DUZ)
;
D EN^BKMVAUD ; Start audit log
D ADDCRBY(REGISTER,BKMIEN,DUZ),ADDCRDT(REGISTER,BKMIEN,DT)
D ADDSTAT(REGISTER,BKMIEN,STATUS),ADDSTDT(REGISTER,BKMIEN,DT)
I $G(DIAGCAT)'="" D ADDCAT(REGISTER,BKMIEN,DIAGCAT)
I $G(DIAGSTAT)'="" D ADDCLASS(REGISTER,BKMIEN,DIAGSTAT),ADDCLADT(REGISTER,BKMIEN,DT)
D POST^BKMVAUD ; End audit log
;
I $G(BKMIEN)=""!($G(BKMREG)="") W !,"Error, A patient ID for "_ADD(DFN)_" wasn't created in HMS." Q
;PRXM/HC/BHS - Removed 8/31/2005 per client request Bug #971
;S DA=BKMIEN
;D ID^BKMILK ; Create patient ID and assign to patient.
; I ($P(Y,U,1)'?1.N)!'$P(Y,U,3) W !,Patient ",DFN," not added."
D ^XBFMK ; Kills off a lot of Fileman variables
QUIT
ADDENT(X) ; add the entry
S DIC(0)="L",DIC("DR")=".01////"
S DIC="^BKM(90451,",DLAYGO=90451
D FILE^DICN
K DIFILE,DIC,DLAYGO
QUIT
;
; Add the new patient entry to the HIV register.
ADDTOREG(REGISTER,ENTRY) ;
NEW DIC,X,DA,DLAYGO
S DIC("DR")=".01////",X=REGISTER,DIC(0)="L"
S DA(1)=ENTRY,DIC="^BKM(90451,"_ENTRY_",1,"
S DLAYGO=90451.1
D FILE^DICN
QUIT
ADDCRBY(REGISTER,ENTRY,CRBYUSER) ;
NEW DIC,DR,DIE,DA
S DA=$O(^BKM(90451,ENTRY,1,"B",REGISTER,""))
Q:DA=""
S DR=".025////"_CRBYUSER
S DA(1)=ENTRY
S DIE="^BKM(90451,"_ENTRY_",1,"
D ^DIE
QUIT
ADDCRDT(REGISTER,ENTRY,DT) ;
NEW DIC,DR,DIE,DA
S DA(1)=ENTRY
S DA=$O(^BKM(90451,ENTRY,1,"B",REGISTER,""))
Q:DA=""
S DR=".02////"_DT
S DA(1)=ENTRY
S DIE="^BKM(90451,"_ENTRY_",1,"
D ^DIE
QUIT
ADDSTAT(REGISTER,ENTRY,STAT) ;
NEW DIC,DR,DIE,DA
S DA=$O(^BKM(90451,ENTRY,1,"B",REGISTER,""))
Q:DA=""
S DR=".5////"_STAT
S DA(1)=ENTRY
S DIE="^BKM(90451,"_ENTRY_",1,"
D ^DIE
QUIT
ADDSTDT(REGISTER,ENTRY,DT) ;
NEW DIC,DR,DIE,DLAYGO,DA
S DA=$O(^BKM(90451,ENTRY,1,"B",REGISTER,""))
Q:DA=""
S DR=".75////"_DT
S DA(1)=ENTRY
S DIE="^BKM(90451,"_ENTRY_",1,"
D ^DIE
QUIT
GETPAT(DFN) ;
K DIC,DTOUT,DUOUT,X,Y,DOB,AGE,PNT,IEN
S DIC=9000001 ; S DIC=90451
S DIC(0)="AEMQZ"
K DTOUT,DUOUT
D ^DIC
I $D(DTOUT)!$D(DUOUT)!$G(Y)<1 Q 0
K DIC,DA,DD,DR,DINUM,D,DLAYGO,DIADD
S DFN=$P(Y,"^",2),IEN=+Y,PNT=$G(Y(0,0))
I DFN="" Q 0
S BKMIEN=$O(^BKM(90451,"B",DFN,""))
S BKMREG="" S:BKMIEN'="" BKMREG=$O(^BKM(90451,BKMIEN,1,"B",1,""))
QUIT 1
STATUS() ;STATUS
S DIR(0)="S^"_$P($G(^DD(90451.01,.5,0)),U,3)
S DIR("A")=$P($G(^DD(90451.01,.5,0)),U,1)
D ^DIR
K DIR
QUIT $G(Y)
GETOCCUP(DUZ) ;GETOCCUP
N OCCUP,IENS
Q:$G(DUZ)="" ""
S DA(1)=REGISTER
S DA=$O(^BKM(90450,REGISTER,11,"B",DUZ,""))
Q:DA="" ""
S IENS=$$IENS^DILF(.DA)
S OCCUP=$$GET1^DIQ(90450.011,IENS,.5,"I")
K DA
QUIT OCCUP
DIAGCAT() ;^DD(90451.01,2.3,0)=
; MHS DIAGNOSIS CATEGORY^S^R:AT RISK;H:HIV;A:AIDS;EK:
; EXPOSED SOURCE KNOWN;EI:INFANT EXPOSED;EO:OCCUPATIONAL EXPOSURE;EN:
; NONOCCUPATIONAL EXPOSURE;EU:EXPOSED SOURCE UNKNOWN;^3;7^Q
; 3)=Enter one of the 8 diagnosis categories for this patient
S DIR(0)="S^"_$P($G(^DD(90451.01,2.3,0)),U,3)
S DIR("A")=$P($G(^DD(90451.01,2.3,0)),U,1)
D ^DIR
K DIR
QUIT $G(Y)
CLINCLAS() ; Clinical Classification
K DIC,DTOUT,DUOUT,X,Y
S DIC=90451.7 ; S DIC=90451
S DIC(0)="AEMQZ"
D ^DIC
I $D(DTOUT)!$D(DUOUT)!$G(Y)<1 Q ""
K DIC
QUIT $G(Y)
ADDCAT(REGISTER,ENTRY,CAT) ;
NEW DIC,DR,DIE,DLAYGO,DA
S DA=$O(^BKM(90451,ENTRY,1,"B",REGISTER,""))
Q:DA=""
S DR="2.3////"_CAT
S DA(1)=ENTRY
S DIE="^BKM(90451,"_ENTRY_",1,"
D ^DIE
QUIT
ADDCLASS(REGISTER,ENTRY,CLASS) ;
NEW DIC,DR,DIE,DLAYGO,DA
S DA=$O(^BKM(90451,ENTRY,1,"B",REGISTER,""))
Q:DA=""
S DR="3////"_CLASS
S DA(1)=ENTRY
S DIE="^BKM(90451,"_ENTRY_",1,"
D ^DIE
QUIT
ADDCLADT(REGISTER,ENTRY,CDATE) ;
NEW DIC,DR,DIE,DLAYGO,DA
S DA=$O(^BKM(90451,ENTRY,1,"B",REGISTER,""))
Q:DA=""
S DR="3.5////"_CDATE
S DA(1)=ENTRY
S DIE="^BKM(90451,"_ENTRY_",1,"
D ^DIE
QUIT
BKMVF1 ;PRXM/HC/JGH - Manually Add Patient To Register ; 17 Jul 2005 1:31 PM
+1 ;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011
+2 QUIT
PROMPT ;Prompt user for Patient
+1 NEW DFN,ADD,REGISTER,PATIENT,STATUS,OPTPAR,OPTS,OPTA,YN
+2 SET REGISTER=$$HIVIEN^BKMIXX3()
+3 IF REGISTER=""
DO EN^DDIOL("There is no HMS register defined.")
HANG 2
QUIT
+4 ;
+5 ; The following line no longer applies
+6 ;I '$D(^BKM(90450,REGISTER,11,"B",DUZ)) D EN^DDIOL("You are not a valid HMS user.") H 2 Q
+7 ;
+8 FOR
IF '$$GETPAT(.DFN)
QUIT
Begin DoDot:1
+9 SET ENTRY=$ORDER(^BKM(90451,"B",DFN,""))
+10 IF ENTRY'=""
IF $DATA(^BKM(90451,"D",REGISTER,ENTRY))
WRITE !!,PNT,": is already in the register.",!!
QUIT
+11 SET STATUS="R"
+12 ; Only File Managers are able to change the status.
IF $$GETOCCUP(DUZ)="M"
SET STATUS=$$STATUS
+13 IF STATUS="^"!(STATUS="")
WRITE !!,"The patient wasn't added to the register."
QUIT
+14 SET DIAGCAT=$$DIAG^BKMIXX3()
IF DIAGCAT=-1
SET DIAGCAT="^"
+15 IF DIAGCAT="^"!(DIAGCAT="")
WRITE !!,"The patient wasn't added to the register."
QUIT
+16 SET DIAGSTAT=""
+17 IF DIAGCAT="H"!(DIAGCAT="A")
SET DIAGSTAT=$$CLINCLAS
IF DIAGSTAT="^"!(DIAGSTAT="")
WRITE !!,"The patient wasn't added to the register."
QUIT
+18 SET OPTA="Add the selected patient to the HMS register"
SET OPTS=""
+19 SET OPTPAR="Y"
+20 SET YN=$$PROMPT2^BKMIXX4(OPTPAR,.OPTS,OPTA)
IF YN<1!(YN["^")
WRITE !!,"The patient wasn't added to the register."
QUIT
+21 DO ADD(DFN,STATUS)
+22 IF $$BASETMP^BKMIXX3(DFN)
DO EN^VALM("BKMV R/E PATIENT RECORD",)
+23 WRITE @IOF,"The patient has been added to the register.",!!
HANG 2
End DoDot:1
+24 KILL DIAGCAT,DIAGSTAT
+25 QUIT
ADD(DFN,STATUS) ; add the patient to the register with status of "R" (unreviewed)
+1 NEW BKMIEN,BKMREG
+2 ; Kills off a lot of Fileman variables
DO ^XBFMK
+3 ; BKMIEN and BKMREG are used by the routine BKMVAUD
SET BKMIEN=$ORDER(^BKM(90451,"B",DFN,""))
+4 ; Create entry in ICare registry for patient.
IF BKMIEN=""
DO ADDENT(DFN)
SET BKMIEN=$ORDER(^BKM(90451,"B",DFN,""))
+5 ; end audit log
IF BKMIEN=""
WRITE !,"Error, An entry for "_ADD(DFN)_" wasn't created in HMS."
QUIT
+6 SET BKMREG=$ORDER(^BKM(90451,BKMIEN,1,"B",REGISTER,""))
+7 IF BKMREG=""
DO ADDTOREG(REGISTER,BKMIEN)
SET BKMREG=$ORDER(^BKM(90451,BKMIEN,1,"B",REGISTER,""))
+8 ; end audit log
IF BKMREG=""
WRITE !,"Error, An entry for "_ADD(DFN)_" wasn't created in HMS."
QUIT
+9 ;
+10 ; Enter audit entry for the NEW record
+11 DO NEW^BKMVAUDN(BKMIEN,BKMREG,DUZ)
+12 ;
+13 ; Start audit log
DO EN^BKMVAUD
+14 DO ADDCRBY(REGISTER,BKMIEN,DUZ)
DO ADDCRDT(REGISTER,BKMIEN,DT)
+15 DO ADDSTAT(REGISTER,BKMIEN,STATUS)
DO ADDSTDT(REGISTER,BKMIEN,DT)
+16 IF $GET(DIAGCAT)'=""
DO ADDCAT(REGISTER,BKMIEN,DIAGCAT)
+17 IF $GET(DIAGSTAT)'=""
DO ADDCLASS(REGISTER,BKMIEN,DIAGSTAT)
DO ADDCLADT(REGISTER,BKMIEN,DT)
+18 ; End audit log
DO POST^BKMVAUD
+19 ;
+20 IF $GET(BKMIEN)=""!($GET(BKMREG)="")
WRITE !,"Error, A patient ID for "_ADD(DFN)_" wasn't created in HMS."
QUIT
+21 ;PRXM/HC/BHS - Removed 8/31/2005 per client request Bug #971
+22 ;S DA=BKMIEN
+23 ;D ID^BKMILK ; Create patient ID and assign to patient.
+24 ; I ($P(Y,U,1)'?1.N)!'$P(Y,U,3) W !,Patient ",DFN," not added."
+25 ; Kills off a lot of Fileman variables
DO ^XBFMK
+26 QUIT
ADDENT(X) ; add the entry
+1 SET DIC(0)="L"
SET DIC("DR")=".01////"
+2 SET DIC="^BKM(90451,"
SET DLAYGO=90451
+3 DO FILE^DICN
+4 KILL DIFILE,DIC,DLAYGO
+5 QUIT
+6 ;
+7 ; Add the new patient entry to the HIV register.
ADDTOREG(REGISTER,ENTRY) ;
+1 NEW DIC,X,DA,DLAYGO
+2 SET DIC("DR")=".01////"
SET X=REGISTER
SET DIC(0)="L"
+3 SET DA(1)=ENTRY
SET DIC="^BKM(90451,"_ENTRY_",1,"
+4 SET DLAYGO=90451.1
+5 DO FILE^DICN
+6 QUIT
ADDCRBY(REGISTER,ENTRY,CRBYUSER) ;
+1 NEW DIC,DR,DIE,DA
+2 SET DA=$ORDER(^BKM(90451,ENTRY,1,"B",REGISTER,""))
+3 IF DA=""
QUIT
+4 SET DR=".025////"_CRBYUSER
+5 SET DA(1)=ENTRY
+6 SET DIE="^BKM(90451,"_ENTRY_",1,"
+7 DO ^DIE
+8 QUIT
ADDCRDT(REGISTER,ENTRY,DT) ;
+1 NEW DIC,DR,DIE,DA
+2 SET DA(1)=ENTRY
+3 SET DA=$ORDER(^BKM(90451,ENTRY,1,"B",REGISTER,""))
+4 IF DA=""
QUIT
+5 SET DR=".02////"_DT
+6 SET DA(1)=ENTRY
+7 SET DIE="^BKM(90451,"_ENTRY_",1,"
+8 DO ^DIE
+9 QUIT
ADDSTAT(REGISTER,ENTRY,STAT) ;
+1 NEW DIC,DR,DIE,DA
+2 SET DA=$ORDER(^BKM(90451,ENTRY,1,"B",REGISTER,""))
+3 IF DA=""
QUIT
+4 SET DR=".5////"_STAT
+5 SET DA(1)=ENTRY
+6 SET DIE="^BKM(90451,"_ENTRY_",1,"
+7 DO ^DIE
+8 QUIT
ADDSTDT(REGISTER,ENTRY,DT) ;
+1 NEW DIC,DR,DIE,DLAYGO,DA
+2 SET DA=$ORDER(^BKM(90451,ENTRY,1,"B",REGISTER,""))
+3 IF DA=""
QUIT
+4 SET DR=".75////"_DT
+5 SET DA(1)=ENTRY
+6 SET DIE="^BKM(90451,"_ENTRY_",1,"
+7 DO ^DIE
+8 QUIT
GETPAT(DFN) ;
+1 KILL DIC,DTOUT,DUOUT,X,Y,DOB,AGE,PNT,IEN
+2 ; S DIC=90451
SET DIC=9000001
+3 SET DIC(0)="AEMQZ"
+4 KILL DTOUT,DUOUT
+5 DO ^DIC
+6 IF $DATA(DTOUT)!$DATA(DUOUT)!$GET(Y)<1
QUIT 0
+7 KILL DIC,DA,DD,DR,DINUM,D,DLAYGO,DIADD
+8 SET DFN=$PIECE(Y,"^",2)
SET IEN=+Y
SET PNT=$GET(Y(0,0))
+9 IF DFN=""
QUIT 0
+10 SET BKMIEN=$ORDER(^BKM(90451,"B",DFN,""))
+11 SET BKMREG=""
IF BKMIEN'=""
SET BKMREG=$ORDER(^BKM(90451,BKMIEN,1,"B",1,""))
+12 QUIT 1
STATUS() ;STATUS
+1 SET DIR(0)="S^"_$PIECE($GET(^DD(90451.01,.5,0)),U,3)
+2 SET DIR("A")=$PIECE($GET(^DD(90451.01,.5,0)),U,1)
+3 DO ^DIR
+4 KILL DIR
+5 QUIT $GET(Y)
GETOCCUP(DUZ) ;GETOCCUP
+1 NEW OCCUP,IENS
+2 IF $GET(DUZ)=""
QUIT ""
+3 SET DA(1)=REGISTER
+4 SET DA=$ORDER(^BKM(90450,REGISTER,11,"B",DUZ,""))
+5 IF DA=""
QUIT ""
+6 SET IENS=$$IENS^DILF(.DA)
+7 SET OCCUP=$$GET1^DIQ(90450.011,IENS,.5,"I")
+8 KILL DA
+9 QUIT OCCUP
DIAGCAT() ;^DD(90451.01,2.3,0)=
+1 ; MHS DIAGNOSIS CATEGORY^S^R:AT RISK;H:HIV;A:AIDS;EK:
+2 ; EXPOSED SOURCE KNOWN;EI:INFANT EXPOSED;EO:OCCUPATIONAL EXPOSURE;EN:
+3 ; NONOCCUPATIONAL EXPOSURE;EU:EXPOSED SOURCE UNKNOWN;^3;7^Q
+4 ; 3)=Enter one of the 8 diagnosis categories for this patient
+5 SET DIR(0)="S^"_$PIECE($GET(^DD(90451.01,2.3,0)),U,3)
+6 SET DIR("A")=$PIECE($GET(^DD(90451.01,2.3,0)),U,1)
+7 DO ^DIR
+8 KILL DIR
+9 QUIT $GET(Y)
CLINCLAS() ; Clinical Classification
+1 KILL DIC,DTOUT,DUOUT,X,Y
+2 ; S DIC=90451
SET DIC=90451.7
+3 SET DIC(0)="AEMQZ"
+4 DO ^DIC
+5 IF $DATA(DTOUT)!$DATA(DUOUT)!$GET(Y)<1
QUIT ""
+6 KILL DIC
+7 QUIT $GET(Y)
ADDCAT(REGISTER,ENTRY,CAT) ;
+1 NEW DIC,DR,DIE,DLAYGO,DA
+2 SET DA=$ORDER(^BKM(90451,ENTRY,1,"B",REGISTER,""))
+3 IF DA=""
QUIT
+4 SET DR="2.3////"_CAT
+5 SET DA(1)=ENTRY
+6 SET DIE="^BKM(90451,"_ENTRY_",1,"
+7 DO ^DIE
+8 QUIT
ADDCLASS(REGISTER,ENTRY,CLASS) ;
+1 NEW DIC,DR,DIE,DLAYGO,DA
+2 SET DA=$ORDER(^BKM(90451,ENTRY,1,"B",REGISTER,""))
+3 IF DA=""
QUIT
+4 SET DR="3////"_CLASS
+5 SET DA(1)=ENTRY
+6 SET DIE="^BKM(90451,"_ENTRY_",1,"
+7 DO ^DIE
+8 QUIT
ADDCLADT(REGISTER,ENTRY,CDATE) ;
+1 NEW DIC,DR,DIE,DLAYGO,DA
+2 SET DA=$ORDER(^BKM(90451,ENTRY,1,"B",REGISTER,""))
+3 IF DA=""
QUIT
+4 SET DR="3.5////"_CDATE
+5 SET DA(1)=ENTRY
+6 SET DIE="^BKM(90451,"_ENTRY_",1,"
+7 DO ^DIE
+8 QUIT
