- 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
