BKMVA5 ;PRXM/HC/JGH - HMS PATIENT REGISTER; [ 1/19/2005 7:16 PM ] ; 10 Jun 2005 1:36 PM
;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011
;
Q
;
EN ;ENTRY POINT -- ListMan template BKMV PCC MED UPDATE
; Called by Add New Data option for Medications
; Assumes existence of DFN,DUZ
N HIVIEN
S HIVIEN=$$HIVIEN^BKMIXX3()
I HIVIEN="" W !,"There is no HMS register defined." H 2 Q
I '$$VALID^BKMIXX3(DUZ) Q
I '$$BKMPRIV^BKMIXX3(DUZ) D NOGO^BKMIXX3 Q
K ^TMP("BKMVA5",$J)
D ^XBFMK
D EN^VALM("BKMV PCC MED UPDATE")
D ^XBFMK
D EXIT
Q
;
HDR ; -- header code
; Assumes existence of DUZ
N DA,IENS,SITE
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)_"]"
S VALMHDR(2)=$G(RCRDHDR)
Q
;
INIT ; -- init variables and list array
; Assumes existence of DFN
D GETALL(DFN)
Q
;
GETALL(DFN) ; Build ListMan display array of patient medication information
; Input variables:
; DFN - IEN for File 2
; Output variables:
; VALMAR - Builds ListMan array
; VALMCNT - List array count
; VALM0
N DA0,DA1,TEXT,MEDDT,IENS,PMEDDT
D ^XBFMK
S VALMCNT=0,VALMAR="^TMP(""BKMVA5"","""_$J_""")",VALM0=""
S DA1=$O(^BKM(90459,"B",$J,""))
Q:DA1=""
S (MEDDT,PMEDDT)=""
F S MEDDT=$O(^BKM(90459,DA1,14,"B",MEDDT),-1) Q:MEDDT="" D
. S DA0=""
. F S DA0=$O(^BKM(90459,DA1,14,"B",MEDDT,DA0)) Q:DA0="" D
. . S DA(1)=DA1,DA=DA0
. . S IENS=$$IENS^DILF(.DA)
. . S VALMCNT=$G(VALMCNT)+1
. . S TEXT=""
. . S TEXT=$$SETFLD^VALM1($$PAD^BKMIXX4(VALMCNT,"<"," ",3)_".",TEXT,"Item")
. . ;S TEXT=$$SETFLD^VALM1($$FMTE^XLFDT($$GET1^DIQ(90459.1414,IENS,".01","I"),"5Z"),TEXT,"Visit")
. . ; Display only date when it does not equal the previous date
. . S TEXT=$$SETFLD^VALM1($S((MEDDT\1)'=(PMEDDT\1):$$FMTE^XLFDT(MEDDT\1,"5Z"),1:""),TEXT,"Visit")
. . S TEXT=$$SETFLD^VALM1($$GET1^DIQ(90459.1414,IENS,".02","E"),TEXT,"Medication")
. . S TEXT=$$SETFLD^VALM1($$GET1^DIQ(90459.1414,IENS,".04","E"),TEXT,"Instructions")
. . S TEXT=$$SETFLD^VALM1($$GET1^DIQ(90459.1414,IENS,".03","E"),TEXT,"Qty")
. . S TEXT=$$SETFLD^VALM1($$GET1^DIQ(90459.1414,IENS,".07","E"),TEXT,"Days")
. . D SET^VALM10(VALMCNT,TEXT,DA0)
. . S PMEDDT=MEDDT
D ^XBFMK
Q
;
ADD ; Add entry to File 90459
D FULL^VALM1
N DA,DA1,DA0,DIC,Y,DIE,DR,BKMDTM,IENS,BKMMED,DIK,BKMDOD
S (DA(1),DA1)=$O(^BKM(90459,"B",$J,""))
Q:DA(1)=""
; Default to today's date for prompt, except for deceased patients
;S X=$$NOW^XLFDT()
S X=$$DT^XLFDT()
S BKMDOD=$$GET1^DIQ(2,DFN,".351","I")
I BKMDOD'="" S X=$$FMADD^XLFDT(BKMDOD,-1)
S DIC="^BKM(90459,"_DA(1)_",14,"
S DIC(0)="L"
; Add new entry
K DO
D FILE^DICN
I Y=-1 G ADDX
S DA0=+Y
ADD1 ; Edit Exam fields in subfile
S DIE="^BKM(90459,"_DA1_",14,"
; Internal entry number of subentry chosen
S DA=DA0,DA(1)=DA1
S DR=".02;.01;.04;.03;.07"
D ^DIE
K DA
S DA=DA0,DA(1)=DA1,IENS=$$IENS^DILF(.DA)
S BKMDTM=$$GET1^DIQ(90459.1414,IENS,".01","I")
S BKMMED=$$GET1^DIQ(90459.1414,IENS,".02","I")
I BKMDTM=""!(BKMMED="") D G ADDX
. K DA
. S DA=DA0,DA(1)=DA1
. S DIK="^BKM(90459,"_DA(1)_",14,"
. D ^DIK
. W " *** Required field(s) missing, entry deleted! ***" H 1
I $P(BKMDTM,".")#100=0!(BKMDTM=(BKMDTM\1)) D
. ; Default to first day of month, if date is imprecise
. I $P(BKMDTM,".")#100=0 D
. . S BKMDTM=$S($L(BKMDTM,".")=2:($P(BKMDTM,".")+1)_"."_$P(BKMDTM,".",2),1:$P(BKMDTM,".")+1)
. ; Default time to noon, if not included, unless it is in the future
. I BKMDTM=(BKMDTM\1) D
. . S BKMDTM=BKMDTM_".1200"
. . I BKMDTM>$$NOW^XLFDT() S BKMDTM=$$NOW^XLFDT()
. S DR=".01///"_BKMDTM
. D ^DIE
;
ADDX ; Add entry exit point
K ^TMP("BKMVA5",$J)
D INIT
Q
;
EDIT ; Edit File 90459
I +$G(VALMCNT)=0 D EN^DDIOL("No items to select") H 2 Q
D FULL^VALM1
N BKMLST,BKMI,VALMI,VALMAT,DA,DIE,DR,BKMDTM
S BKMLST=$$SELECT^BKMVD2()
I BKMLST'="" D
. F BKMI=1:1:$L(BKMLST,",") S VALMI=$P(BKMLST,",",BKMI) Q:'VALMI D
. . S VALMAT=$O(@VALMAR@("IDX",VALMI,""))
. . Q:VALMAT=""
. . S DA(1)=$O(^BKM(90459,"B",$J,""))
. . Q:DA(1)=""
. . S DA=VALMAT
. . S DIE="^BKM(90459,"_DA(1)_",14,"
. . S DR=".02;.01;.04;.03;.07"
. . D ^DIE
. . ; If user deleted .01 field, DA is killed so quit this iteration
. . I '$D(DA) Q
. . S BKMDTM=$$GET1^DIQ(90459.1414,DA_","_DA(1)_",",.01,"I")
. . I $P(BKMDTM,".")#100=0!(BKMDTM=(BKMDTM\1)) D
. . . ; Default to first day of month, if date is imprecise
. . . I $P(BKMDTM,".")#100=0 D
. . . . S BKMDTM=$S($L(BKMDTM,".")=2:($P(BKMDTM,".")+1)_"."_$P(BKMDTM,".",2),1:$P(BKMDTM,".")+1)
. . . ; Default time to noon, if not included, unless it is in the future
. . . I BKMDTM=(BKMDTM\1) D
. . . . S BKMDTM=BKMDTM_".1200"
. . . . I BKMDTM>$$NOW^XLFDT() S BKMDTM=$$NOW^XLFDT()
. . . S DR=".01///"_BKMDTM
. . . D ^DIE
. . W " Edited!" H 2
K ^TMP("BKMVA5",$J)
D INIT
Q
;
DELETE ; Delete entry in File 90459
I +$G(VALMCNT)=0 D EN^DDIOL("No items to select") H 2 Q
D FULL^VALM1
N BKMLST,BKMI,VALMI,VALMAT,DA,DIK
S BKMLST=$$SELECT^BKMVD2()
I BKMLST'="" D
. F BKMI=1:1:$L(BKMLST,",") S VALMI=$P(BKMLST,",",BKMI) Q:'VALMI D
. . S VALMAT=$O(@VALMAR@("IDX",VALMI,""))
. . Q:VALMAT=""
. . ; Confirm deletion
. . I '$$YNP^BKMVD2("Confirm deletion of Item "_VALMI,"NO") Q
. . S DA(1)=$O(^BKM(90459,"B",$J,""))
. . Q:DA(1)=""
. . S DA=VALMAT
. . S DIK="^BKM(90459,"_DA(1)_",14,"
. . D ^DIK
. . W " Deleted!" H 2
K ^TMP("BKMVA5",$J)
D INIT
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !
Q
;
EXIT ;clean up used variables
K ^TMP("BKMVA5",$J)
K VALM0,VALMAR,VALMCNT,VALMHDR
Q
;
;
BKMVA5 ;PRXM/HC/JGH - HMS PATIENT REGISTER; [ 1/19/2005 7:16 PM ] ; 10 Jun 2005 1:36 PM
+1 ;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011
+2 ;
+3 QUIT
+4 ;
EN ;ENTRY POINT -- ListMan template BKMV PCC MED UPDATE
+1 ; Called by Add New Data option for Medications
+2 ; Assumes existence of DFN,DUZ
+3 NEW HIVIEN
+4 SET HIVIEN=$$HIVIEN^BKMIXX3()
+5 IF HIVIEN=""
WRITE !,"There is no HMS register defined."
HANG 2
QUIT
+6 IF '$$VALID^BKMIXX3(DUZ)
QUIT
+7 IF '$$BKMPRIV^BKMIXX3(DUZ)
DO NOGO^BKMIXX3
QUIT
+8 KILL ^TMP("BKMVA5",$JOB)
+9 DO ^XBFMK
+10 DO EN^VALM("BKMV PCC MED UPDATE")
+11 DO ^XBFMK
+12 DO EXIT
+13 QUIT
+14 ;
HDR ; -- header code
+1 ; Assumes existence of DUZ
+2 NEW DA,IENS,SITE
+3 SET DA=$GET(DUZ(2))
SET IENS=$$IENS^DILF(.DA)
SET SITE=$$GET1^DIQ(4,IENS,.01,"E")
+4 SET VALMHDR(1)=$$PAD^BKMIXX4("",">"," ",(80-$LENGTH(SITE)+2)\2)_"["_$GET(SITE)_"]"
+5 SET VALMHDR(2)=$GET(RCRDHDR)
+6 QUIT
+7 ;
INIT ; -- init variables and list array
+1 ; Assumes existence of DFN
+2 DO GETALL(DFN)
+3 QUIT
+4 ;
GETALL(DFN) ; Build ListMan display array of patient medication information
+1 ; Input variables:
+2 ; DFN - IEN for File 2
+3 ; Output variables:
+4 ; VALMAR - Builds ListMan array
+5 ; VALMCNT - List array count
+6 ; VALM0
+7 NEW DA0,DA1,TEXT,MEDDT,IENS,PMEDDT
+8 DO ^XBFMK
+9 SET VALMCNT=0
SET VALMAR="^TMP(""BKMVA5"","""_$JOB_""")"
SET VALM0=""
+10 SET DA1=$ORDER(^BKM(90459,"B",$JOB,""))
+11 IF DA1=""
QUIT
+12 SET (MEDDT,PMEDDT)=""
+13 FOR
SET MEDDT=$ORDER(^BKM(90459,DA1,14,"B",MEDDT),-1)
IF MEDDT=""
QUIT
Begin DoDot:1
+14 SET DA0=""
+15 FOR
SET DA0=$ORDER(^BKM(90459,DA1,14,"B",MEDDT,DA0))
IF DA0=""
QUIT
Begin DoDot:2
+16 SET DA(1)=DA1
SET DA=DA0
+17 SET IENS=$$IENS^DILF(.DA)
+18 SET VALMCNT=$GET(VALMCNT)+1
+19 SET TEXT=""
+20 SET TEXT=$$SETFLD^VALM1($$PAD^BKMIXX4(VALMCNT,"<"," ",3)_".",TEXT,"Item")
+21 ;S TEXT=$$SETFLD^VALM1($$FMTE^XLFDT($$GET1^DIQ(90459.1414,IENS,".01","I"),"5Z"),TEXT,"Visit")
+22 ; Display only date when it does not equal the previous date
+23 SET TEXT=$$SETFLD^VALM1($SELECT((MEDDT\1)'=(PMEDDT\1):$$FMTE^XLFDT(MEDDT\1,"5Z"),1:""),TEXT,"Visit")
+24 SET TEXT=$$SETFLD^VALM1($$GET1^DIQ(90459.1414,IENS,".02","E"),TEXT,"Medication")
+25 SET TEXT=$$SETFLD^VALM1($$GET1^DIQ(90459.1414,IENS,".04","E"),TEXT,"Instructions")
+26 SET TEXT=$$SETFLD^VALM1($$GET1^DIQ(90459.1414,IENS,".03","E"),TEXT,"Qty")
+27 SET TEXT=$$SETFLD^VALM1($$GET1^DIQ(90459.1414,IENS,".07","E"),TEXT,"Days")
+28 DO SET^VALM10(VALMCNT,TEXT,DA0)
+29 SET PMEDDT=MEDDT
End DoDot:2
End DoDot:1
+30 DO ^XBFMK
+31 QUIT
+32 ;
ADD ; Add entry to File 90459
+1 DO FULL^VALM1
+2 NEW DA,DA1,DA0,DIC,Y,DIE,DR,BKMDTM,IENS,BKMMED,DIK,BKMDOD
+3 SET (DA(1),DA1)=$ORDER(^BKM(90459,"B",$JOB,""))
+4 IF DA(1)=""
QUIT
+5 ; Default to today's date for prompt, except for deceased patients
+6 ;S X=$$NOW^XLFDT()
+7 SET X=$$DT^XLFDT()
+8 SET BKMDOD=$$GET1^DIQ(2,DFN,".351","I")
+9 IF BKMDOD'=""
SET X=$$FMADD^XLFDT(BKMDOD,-1)
+10 SET DIC="^BKM(90459,"_DA(1)_",14,"
+11 SET DIC(0)="L"
+12 ; Add new entry
+13 KILL DO
+14 DO FILE^DICN
+15 IF Y=-1
GOTO ADDX
+16 SET DA0=+Y
ADD1 ; Edit Exam fields in subfile
+1 SET DIE="^BKM(90459,"_DA1_",14,"
+2 ; Internal entry number of subentry chosen
+3 SET DA=DA0
SET DA(1)=DA1
+4 SET DR=".02;.01;.04;.03;.07"
+5 DO ^DIE
+6 KILL DA
+7 SET DA=DA0
SET DA(1)=DA1
SET IENS=$$IENS^DILF(.DA)
+8 SET BKMDTM=$$GET1^DIQ(90459.1414,IENS,".01","I")
+9 SET BKMMED=$$GET1^DIQ(90459.1414,IENS,".02","I")
+10 IF BKMDTM=""!(BKMMED="")
Begin DoDot:1
+11 KILL DA
+12 SET DA=DA0
SET DA(1)=DA1
+13 SET DIK="^BKM(90459,"_DA(1)_",14,"
+14 DO ^DIK
+15 WRITE " *** Required field(s) missing, entry deleted! ***"
HANG 1
End DoDot:1
GOTO ADDX
+16 IF $PIECE(BKMDTM,".")#100=0!(BKMDTM=(BKMDTM\1))
Begin DoDot:1
+17 ; Default to first day of month, if date is imprecise
+18 IF $PIECE(BKMDTM,".")#100=0
Begin DoDot:2
+19 SET BKMDTM=$SELECT($LENGTH(BKMDTM,".")=2:($PIECE(BKMDTM,".")+1)_"."_$PIECE(BKMDTM,".",2),1:$PIECE(BKMDTM,".")+1)
End DoDot:2
+20 ; Default time to noon, if not included, unless it is in the future
+21 IF BKMDTM=(BKMDTM\1)
Begin DoDot:2
+22 SET BKMDTM=BKMDTM_".1200"
+23 IF BKMDTM>$$NOW^XLFDT()
SET BKMDTM=$$NOW^XLFDT()
End DoDot:2
+24 SET DR=".01///"_BKMDTM
+25 DO ^DIE
End DoDot:1
+26 ;
ADDX ; Add entry exit point
+1 KILL ^TMP("BKMVA5",$JOB)
+2 DO INIT
+3 QUIT
+4 ;
EDIT ; Edit File 90459
+1 IF +$GET(VALMCNT)=0
DO EN^DDIOL("No items to select")
HANG 2
QUIT
+2 DO FULL^VALM1
+3 NEW BKMLST,BKMI,VALMI,VALMAT,DA,DIE,DR,BKMDTM
+4 SET BKMLST=$$SELECT^BKMVD2()
+5 IF BKMLST'=""
Begin DoDot:1
+6 FOR BKMI=1:1:$LENGTH(BKMLST,",")
SET VALMI=$PIECE(BKMLST,",",BKMI)
IF 'VALMI
QUIT
Begin DoDot:2
+7 SET VALMAT=$ORDER(@VALMAR@("IDX",VALMI,""))
+8 IF VALMAT=""
QUIT
+9 SET DA(1)=$ORDER(^BKM(90459,"B",$JOB,""))
+10 IF DA(1)=""
QUIT
+11 SET DA=VALMAT
+12 SET DIE="^BKM(90459,"_DA(1)_",14,"
+13 SET DR=".02;.01;.04;.03;.07"
+14 DO ^DIE
+15 ; If user deleted .01 field, DA is killed so quit this iteration
+16 IF '$DATA(DA)
QUIT
+17 SET BKMDTM=$$GET1^DIQ(90459.1414,DA_","_DA(1)_",",.01,"I")
+18 IF $PIECE(BKMDTM,".")#100=0!(BKMDTM=(BKMDTM\1))
Begin DoDot:3
+19 ; Default to first day of month, if date is imprecise
+20 IF $PIECE(BKMDTM,".")#100=0
Begin DoDot:4
+21 SET BKMDTM=$SELECT($LENGTH(BKMDTM,".")=2:($PIECE(BKMDTM,".")+1)_"."_$PIECE(BKMDTM,".",2),1:$PIECE(BKMDTM,".")+1)
End DoDot:4
+22 ; Default time to noon, if not included, unless it is in the future
+23 IF BKMDTM=(BKMDTM\1)
Begin DoDot:4
+24 SET BKMDTM=BKMDTM_".1200"
+25 IF BKMDTM>$$NOW^XLFDT()
SET BKMDTM=$$NOW^XLFDT()
End DoDot:4
+26 SET DR=".01///"_BKMDTM
+27 DO ^DIE
End DoDot:3
+28 WRITE " Edited!"
HANG 2
End DoDot:2
End DoDot:1
+29 KILL ^TMP("BKMVA5",$JOB)
+30 DO INIT
+31 QUIT
+32 ;
DELETE ; Delete entry in File 90459
+1 IF +$GET(VALMCNT)=0
DO EN^DDIOL("No items to select")
HANG 2
QUIT
+2 DO FULL^VALM1
+3 NEW BKMLST,BKMI,VALMI,VALMAT,DA,DIK
+4 SET BKMLST=$$SELECT^BKMVD2()
+5 IF BKMLST'=""
Begin DoDot:1
+6 FOR BKMI=1:1:$LENGTH(BKMLST,",")
SET VALMI=$PIECE(BKMLST,",",BKMI)
IF 'VALMI
QUIT
Begin DoDot:2
+7 SET VALMAT=$ORDER(@VALMAR@("IDX",VALMI,""))
+8 IF VALMAT=""
QUIT
+9 ; Confirm deletion
+10 IF '$$YNP^BKMVD2("Confirm deletion of Item "_VALMI,"NO")
QUIT
+11 SET DA(1)=$ORDER(^BKM(90459,"B",$JOB,""))
+12 IF DA(1)=""
QUIT
+13 SET DA=VALMAT
+14 SET DIK="^BKM(90459,"_DA(1)_",14,"
+15 DO ^DIK
+16 WRITE " Deleted!"
HANG 2
End DoDot:2
End DoDot:1
+17 KILL ^TMP("BKMVA5",$JOB)
+18 DO INIT
+19 QUIT
+20 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !
+2 QUIT
+3 ;
EXIT ;clean up used variables
+1 KILL ^TMP("BKMVA5",$JOB)
+2 KILL VALM0,VALMAR,VALMCNT,VALMHDR
+3 QUIT
+4 ;
+5 ;
