- BKMVA4 ;PRXM/HC/JGH - HMS PATIENT REGISTER; [ 1/19/2005 7:16 PM ] ; 09 Jun 2005 12:53 PM
- ;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011
- ;
- Q
- ;
- EN ;ENTRY POINT -- ListMan template BKMV PCC LAB UPDATE
- ; Called by Add New Data option for Lab
- ; 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("BKMVA4",$J)
- D ^XBFMK
- D EN^VALM("BKMV PCC LAB 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 lab information
- ; Input variables:
- ; DFN - IEN for File 2
- ; Output variables:
- ; VALMAR - Builds ListMan array
- ; VALMCNT - List array count
- ; VALM0
- N DA0,DA1,TEXT,LABDT,IENS,REFLOW,REFHIGH,BKMRNG,PLABDT
- D ^XBFMK
- S VALMCNT=0,VALMAR="^TMP(""BKMVA4"","""_$J_""")",VALM0=""
- S DA1=$O(^BKM(90459,"B",$J,""))
- Q:DA1=""
- S (LABDT,PLABDT)=""
- F S LABDT=$O(^BKM(90459,DA1,13,"B",LABDT),-1) Q:LABDT="" D
- . S DA0=""
- . F S DA0=$O(^BKM(90459,DA1,13,"B",LABDT,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.1313,IENS,".01","I"),"5Z"),TEXT,"Visit")
- . . ; Display only date when it does not equal the previous date
- . . S TEXT=$$SETFLD^VALM1($S((LABDT\1)'=(PLABDT\1):$$FMTE^XLFDT(LABDT\1,"5Z"),1:""),TEXT,"Visit")
- . . S TEXT=$$SETFLD^VALM1($$GET1^DIQ(90459.1313,IENS,".02","E"),TEXT,"Lab")
- . . S TEXT=$$SETFLD^VALM1($$GET1^DIQ(90459.1313,IENS,".03","E"),TEXT,"Result")
- . . S TEXT=$$SETFLD^VALM1($$GET1^DIQ(90459.1313,IENS,"1101","E"),TEXT,"Units")
- . . S REFLOW=$$GET1^DIQ(90459.1313,IENS,1104,"E")
- . . S REFHIGH=$$GET1^DIQ(90459.1313,IENS,1105,"E")
- . . S BKMRNG=REFLOW_"-"_REFHIGH
- . . I BKMRNG="-" S BKMRNG=""
- . . S TEXT=$$SETFLD^VALM1(BKMRNG,TEXT,"RefRange")
- . . D SET^VALM10(VALMCNT,TEXT,DA0)
- . . S PLABDT=LABDT
- D ^XBFMK
- Q
- ;
- ADD ; Add entry to File 90459
- D FULL^VALM1
- N DA,DA1,DA0,DIC,Y,DIE,DR,BKMDTM,IENS,BKMLAB,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)_",13,"
- 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_",13,"
- ; Internal entry number of subentry chosen
- S DA=DA0,DA(1)=DA1
- S DR=".02;.01;.03;1101;1104;1105"
- D ^DIE
- K DA
- S DA=DA0,DA(1)=DA1,IENS=$$IENS^DILF(.DA)
- S BKMDTM=$$GET1^DIQ(90459.1313,IENS,".01","I")
- S BKMLAB=$$GET1^DIQ(90459.1313,IENS,".02","I")
- I BKMDTM=""!(BKMLAB="") D G ADDX
- . K DA
- . S DA=DA0,DA(1)=DA1
- . S DIK="^BKM(90459,"_DA(1)_",13,"
- . 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("BKMVA4",$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)_",13,"
- . . S DR=".02;.01;.03;1101;1104;1105"
- . . D ^DIE
- . . ; If user deleted .01 field, DA is killed so quit this iteration
- . . I '$D(DA) Q
- . . S BKMDTM=$$GET1^DIQ(90459.1313,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("BKMVA4",$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)_",13,"
- . . D ^DIK
- . . W " Deleted!" H 2
- K ^TMP("BKMVA4",$J)
- D INIT
- Q
- ;
- HELP ; -- help code
- S X="?" D DISP^XQORM1 W !
- Q
- ;
- LABTST ; EP - Input Transform for the Lab Test Value
- ; Exclude panels
- I $O(^LAB(60,X,2,0))'="" K X Q
- Q
- ;
- EXIT ;clean up used variables
- K ^TMP("BKMVA4",$J)
- K VALM0,VALMAR,VALMHDR,VALMCNT
- Q
- ;
- ;
- BKMVA4 ;PRXM/HC/JGH - HMS PATIENT REGISTER; [ 1/19/2005 7:16 PM ] ; 09 Jun 2005 12:53 PM
- +1 ;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011
- +2 ;
- +3 QUIT
- +4 ;
- EN ;ENTRY POINT -- ListMan template BKMV PCC LAB UPDATE
- +1 ; Called by Add New Data option for Lab
- +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("BKMVA4",$JOB)
- +9 DO ^XBFMK
- +10 DO EN^VALM("BKMV PCC LAB 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 lab 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,LABDT,IENS,REFLOW,REFHIGH,BKMRNG,PLABDT
- +8 DO ^XBFMK
- +9 SET VALMCNT=0
- SET VALMAR="^TMP(""BKMVA4"","""_$JOB_""")"
- SET VALM0=""
- +10 SET DA1=$ORDER(^BKM(90459,"B",$JOB,""))
- +11 IF DA1=""
- QUIT
- +12 SET (LABDT,PLABDT)=""
- +13 FOR
- SET LABDT=$ORDER(^BKM(90459,DA1,13,"B",LABDT),-1)
- IF LABDT=""
- QUIT
- Begin DoDot:1
- +14 SET DA0=""
- +15 FOR
- SET DA0=$ORDER(^BKM(90459,DA1,13,"B",LABDT,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.1313,IENS,".01","I"),"5Z"),TEXT,"Visit")
- +22 ; Display only date when it does not equal the previous date
- +23 SET TEXT=$$SETFLD^VALM1($SELECT((LABDT\1)'=(PLABDT\1):$$FMTE^XLFDT(LABDT\1,"5Z"),1:""),TEXT,"Visit")
- +24 SET TEXT=$$SETFLD^VALM1($$GET1^DIQ(90459.1313,IENS,".02","E"),TEXT,"Lab")
- +25 SET TEXT=$$SETFLD^VALM1($$GET1^DIQ(90459.1313,IENS,".03","E"),TEXT,"Result")
- +26 SET TEXT=$$SETFLD^VALM1($$GET1^DIQ(90459.1313,IENS,"1101","E"),TEXT,"Units")
- +27 SET REFLOW=$$GET1^DIQ(90459.1313,IENS,1104,"E")
- +28 SET REFHIGH=$$GET1^DIQ(90459.1313,IENS,1105,"E")
- +29 SET BKMRNG=REFLOW_"-"_REFHIGH
- +30 IF BKMRNG="-"
- SET BKMRNG=""
- +31 SET TEXT=$$SETFLD^VALM1(BKMRNG,TEXT,"RefRange")
- +32 DO SET^VALM10(VALMCNT,TEXT,DA0)
- +33 SET PLABDT=LABDT
- End DoDot:2
- End DoDot:1
- +34 DO ^XBFMK
- +35 QUIT
- +36 ;
- ADD ; Add entry to File 90459
- +1 DO FULL^VALM1
- +2 NEW DA,DA1,DA0,DIC,Y,DIE,DR,BKMDTM,IENS,BKMLAB,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)_",13,"
- +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_",13,"
- +2 ; Internal entry number of subentry chosen
- +3 SET DA=DA0
- SET DA(1)=DA1
- +4 SET DR=".02;.01;.03;1101;1104;1105"
- +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.1313,IENS,".01","I")
- +9 SET BKMLAB=$$GET1^DIQ(90459.1313,IENS,".02","I")
- +10 IF BKMDTM=""!(BKMLAB="")
- Begin DoDot:1
- +11 KILL DA
- +12 SET DA=DA0
- SET DA(1)=DA1
- +13 SET DIK="^BKM(90459,"_DA(1)_",13,"
- +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("BKMVA4",$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)_",13,"
- +13 SET DR=".02;.01;.03;1101;1104;1105"
- +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.1313,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("BKMVA4",$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)_",13,"
- +15 DO ^DIK
- +16 WRITE " Deleted!"
- HANG 2
- End DoDot:2
- End DoDot:1
- +17 KILL ^TMP("BKMVA4",$JOB)
- +18 DO INIT
- +19 QUIT
- +20 ;
- HELP ; -- help code
- +1 SET X="?"
- DO DISP^XQORM1
- WRITE !
- +2 QUIT
- +3 ;
- LABTST ; EP - Input Transform for the Lab Test Value
- +1 ; Exclude panels
- +2 IF $ORDER(^LAB(60,X,2,0))'=""
- KILL X
- QUIT
- +3 QUIT
- +4 ;
- EXIT ;clean up used variables
- +1 KILL ^TMP("BKMVA4",$JOB)
- +2 KILL VALM0,VALMAR,VALMHDR,VALMCNT
- +3 QUIT
- +4 ;
- +5 ;