BKMILK ;PRXM/HC/CLT - LOOKUP ROUTINE FOR ICARE REGISTRY ; 14 Jul 2005 8:06 PM ;
;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011
Q
ID ;DETERMINE AND/OR CREATE A PATIENT ID
Q ;Subroutine disabled due to client request of ID removal
N BKMLOC,BKMH3,BKMH1,BKMH2,BKMID,DR,DIE
I $P(^BKM(90451,DA,0),U,2)'="" Q
S BKMLOC=$E($$GET1^DIQ(4,$G(DUZ(2))_",",.01,"E"),1,3)
;
ID1 ;BUILD OF NUMBER PORTION OF ID
Q
S BKMH3="" F BKMH1=1:1:5 S BKMH2=$R(9) S BKMH3=BKMH3_BKMH2
S BKMID=BKMLOC_BKMH3
I $D(^BKM(90451,"C",BKMID)) S (BKMID,BKMH3)="" D ID1
; Update REGISTER ID
S DR=".05////"_BKMID_";"
S DIE="^BKM(90451,"
D ^DIE
Q
;
AIDSDT ;CHECK TO BE SURE AIDS DATE IS NOT BEFORE THE HIV DATE
; CALLED from File 90451, Input Transform
; Y, DA and DA(1) set by calling process and must be preserved
; QUIT must be set on exit
N AIDSDT,DFN,DOB
I $G(Y)<1 S Y=$$GET1^DIQ(90451.01,DA_","_DA(1)_",",5.5,"I")
S QUIT=0
;S A=B
S AIDSDT=Y
I AIDSDT<$$GET1^DIQ(90451.01,DA_","_DA(1)_",",5,"I") S QUIT=1 Q
S DFN=$$GET1^DIQ(90451,DA(1)_",",.01,"I")
S DOB=$$GET1^DIQ(2,DFN,.03,"I")
I DOB>Y S QUIT=1
Q
HIVDT ;CHECK TO BE SURE HIV DATE IS BEFORE THE AIDS DATE, IF IT EXISTS
; CALLED from File 90451, Input Transform
; Y, DA and DA(1) set by calling process and must be preserved
; QUIT must be set on exit
N HIVDT,DFN,DOB,AIDSDT
I $G(Y)<1 S Y=$$GET1^DIQ(90451.01,DA_","_DA(1)_",",5,"I")
S QUIT=0
S HIVDT=Y
S AIDSDT=$$GET1^DIQ(90451.01,DA_","_DA(1)_",",5.5,"I")
I AIDSDT'="",HIVDT>AIDSDT S QUIT=1 Q
S DFN=$$GET1^DIQ(90451,DA(1)_",",.01,"I")
S DOB=$$GET1^DIQ(2,DFN,.03,"I")
I DOB>Y S QUIT=1
Q
STATBUL ;EP
;PRXM/HC/BHS - Remove bulletins per IHS 9/9/2005
Q
S BKMPT=$$GET1^DIQ(90451,DA(1),.01,"E")
S BKMOSTAT=$$GET1^DIQ(90451.01,DA_","_DA(1)_",",.55,"E")
S BKMNSTAT=$$GET1^DIQ(90451.01,DA_","_DA(1)_",",.5,"E")
S XMY("G.BKMI ALERT")=""
S XMSUB="Register Patient status change"
S ^TMP($J,"BKMIALERT",1)="Status change for Register Patient "_BKMPT_" from "_$S(BKMOSTAT="":"EMPTY",1:BKMOSTAT)_" to "_BKMNSTAT
S XMTEXT="^TMP($J,""BKMIALERT"","
D ^XMD
K XMTEXT,BKMBUL,XMSUB,XMY,^TMP($J,"BKMIALERT"),BKMPT,BKMOSTAT,BKMNSTAT
Q
DXBUL ;EP
;PRXM/HC/BHS - Remove bulletins per IHS 9/9/2005
Q
S BKMPT=$$GET1^DIQ(90451,DA(1),.01,"E")
S BKMODX=$$GET1^DIQ(90451.01,DA_","_DA(1)_",",35,"E")
S BKMNDX=$$GET1^DIQ(90451.01,DA_","_DA(1)_",",2.3,"E")
S XMY("G.BKMI ALERT")=""
S XMSUB="Register Patient Diagnosis change"
S ^TMP($J,"BKMIALERT",1)="Diagnosis change for Register Patient "_BKMPT_" from "_$S(BKMODX="":"EMPTY",1:BKMODX)_" to "_BKMNDX
S XMTEXT="^TMP($J,""BKMIALERT"","
D ^XMD
K XMTEXT,BKMBUL,XMSUB,XMY,^TMP($J,"BKMIALERT"),BKMPT,BKMODX,BKMNDX
Q
MAIL ;
;XMDF=FLAG that programmer interface is in use. Set & killed here only.
; Therefore do not check for Security Keys on domains.
;XMSUB=HEADER
;XMTEXT=@LOCATION OF MESSAGE
;XMSTRIP=CHARACTERS THAT USER WANTS STRIPPED FROM TEXT OF MESSAGE
;XMDTEST=Testing Flag / in test mode if $G(XMDTEST)=1
;XMDUZ=SENDER #
;I $D(XMMG),'$D(XMY) XMMG WILL BE THE DEFAULT FOR THE FIRST SEND TO:
;XMY I '$D(XMY) RECIPIENTS WILL BE PROMPTED FOR
D ^XMD
Q
;
ETIXHLP ; EP - Executable help for Etiology field
N BKMMN,BKMIEN,BKMDATA,BKMCNT,DUOUT,BKMRD
D EN^DDIOL("Choose from:","","!,?3")
S BKMMN="",BKMCNT=0
F S BKMMN=$O(^BKM(90451.5,"D",BKMMN)) Q:BKMMN="" D I $G(DUOUT) Q
. S BKMIEN=0
. F S BKMIEN=$O(^BKM(90451.5,"D",BKMMN,BKMIEN)) Q:BKMIEN="" D I $G(DUOUT) Q
. . S BKMDATA=$G(^BKM(90451.5,BKMIEN,0)) Q:BKMDATA=""
. . S BKMCNT=BKMCNT+1
. . D EN^DDIOL($$PAD^BKMIXX4($P(BKMDATA,U,2),">"," ",10)_$E($P(BKMDATA,U,1),1,70),"","!,?3")
. . I BKMCNT=10 D I $G(DUOUT) Q
. . . I $$PAUSE^BKMIXX3 S DUOUT=1 Q
. . . ;R !,"'^' TO STOP: ",BKMRD:DTIME S:'$T BKMRD=U
. . . ;I BKMRD[U S DUOUT=1 Q
. . . S BKMCNT=0
; Reset DV to "" to prevent generic help from displaying
S DV=""
Q
;
XIT ;EXIT THE LOOKUP PROCEDURE
K BKMNEW,DIC,DIE,X,Y,DA,BKMID,BKMH3,BKMH2,BKMID,BKMLOC,BKMH1
BKMILK ;PRXM/HC/CLT - LOOKUP ROUTINE FOR ICARE REGISTRY ; 14 Jul 2005 8:06 PM ;
+1 ;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011
+2 QUIT
ID ;DETERMINE AND/OR CREATE A PATIENT ID
+1 ;Subroutine disabled due to client request of ID removal
QUIT
+2 NEW BKMLOC,BKMH3,BKMH1,BKMH2,BKMID,DR,DIE
+3 IF $PIECE(^BKM(90451,DA,0),U,2)'=""
QUIT
+4 SET BKMLOC=$EXTRACT($$GET1^DIQ(4,$GET(DUZ(2))_",",.01,"E"),1,3)
+5 ;
ID1 ;BUILD OF NUMBER PORTION OF ID
+1 QUIT
+2 SET BKMH3=""
FOR BKMH1=1:1:5
SET BKMH2=$RANDOM(9)
SET BKMH3=BKMH3_BKMH2
+3 SET BKMID=BKMLOC_BKMH3
+4 IF $DATA(^BKM(90451,"C",BKMID))
SET (BKMID,BKMH3)=""
DO ID1
+5 ; Update REGISTER ID
+6 SET DR=".05////"_BKMID_";"
+7 SET DIE="^BKM(90451,"
+8 DO ^DIE
+9 QUIT
+10 ;
AIDSDT ;CHECK TO BE SURE AIDS DATE IS NOT BEFORE THE HIV DATE
+1 ; CALLED from File 90451, Input Transform
+2 ; Y, DA and DA(1) set by calling process and must be preserved
+3 ; QUIT must be set on exit
+4 NEW AIDSDT,DFN,DOB
+5 IF $GET(Y)<1
SET Y=$$GET1^DIQ(90451.01,DA_","_DA(1)_",",5.5,"I")
+6 SET QUIT=0
+7 ;S A=B
+8 SET AIDSDT=Y
+9 IF AIDSDT<$$GET1^DIQ(90451.01,DA_","_DA(1)_",",5,"I")
SET QUIT=1
QUIT
+10 SET DFN=$$GET1^DIQ(90451,DA(1)_",",.01,"I")
+11 SET DOB=$$GET1^DIQ(2,DFN,.03,"I")
+12 IF DOB>Y
SET QUIT=1
+13 QUIT
HIVDT ;CHECK TO BE SURE HIV DATE IS BEFORE THE AIDS DATE, IF IT EXISTS
+1 ; CALLED from File 90451, Input Transform
+2 ; Y, DA and DA(1) set by calling process and must be preserved
+3 ; QUIT must be set on exit
+4 NEW HIVDT,DFN,DOB,AIDSDT
+5 IF $GET(Y)<1
SET Y=$$GET1^DIQ(90451.01,DA_","_DA(1)_",",5,"I")
+6 SET QUIT=0
+7 SET HIVDT=Y
+8 SET AIDSDT=$$GET1^DIQ(90451.01,DA_","_DA(1)_",",5.5,"I")
+9 IF AIDSDT'=""
IF HIVDT>AIDSDT
SET QUIT=1
QUIT
+10 SET DFN=$$GET1^DIQ(90451,DA(1)_",",.01,"I")
+11 SET DOB=$$GET1^DIQ(2,DFN,.03,"I")
+12 IF DOB>Y
SET QUIT=1
+13 QUIT
STATBUL ;EP
+1 ;PRXM/HC/BHS - Remove bulletins per IHS 9/9/2005
+2 QUIT
+3 SET BKMPT=$$GET1^DIQ(90451,DA(1),.01,"E")
+4 SET BKMOSTAT=$$GET1^DIQ(90451.01,DA_","_DA(1)_",",.55,"E")
+5 SET BKMNSTAT=$$GET1^DIQ(90451.01,DA_","_DA(1)_",",.5,"E")
+6 SET XMY("G.BKMI ALERT")=""
+7 SET XMSUB="Register Patient status change"
+8 SET ^TMP($JOB,"BKMIALERT",1)="Status change for Register Patient "_BKMPT_" from "_$SELECT(BKMOSTAT="":"EMPTY",1:BKMOSTAT)_" to "_BKMNSTAT
+9 SET XMTEXT="^TMP($J,""BKMIALERT"","
+10 DO ^XMD
+11 KILL XMTEXT,BKMBUL,XMSUB,XMY,^TMP($JOB,"BKMIALERT"),BKMPT,BKMOSTAT,BKMNSTAT
+12 QUIT
DXBUL ;EP
+1 ;PRXM/HC/BHS - Remove bulletins per IHS 9/9/2005
+2 QUIT
+3 SET BKMPT=$$GET1^DIQ(90451,DA(1),.01,"E")
+4 SET BKMODX=$$GET1^DIQ(90451.01,DA_","_DA(1)_",",35,"E")
+5 SET BKMNDX=$$GET1^DIQ(90451.01,DA_","_DA(1)_",",2.3,"E")
+6 SET XMY("G.BKMI ALERT")=""
+7 SET XMSUB="Register Patient Diagnosis change"
+8 SET ^TMP($JOB,"BKMIALERT",1)="Diagnosis change for Register Patient "_BKMPT_" from "_$SELECT(BKMODX="":"EMPTY",1:BKMODX)_" to "_BKMNDX
+9 SET XMTEXT="^TMP($J,""BKMIALERT"","
+10 DO ^XMD
+11 KILL XMTEXT,BKMBUL,XMSUB,XMY,^TMP($JOB,"BKMIALERT"),BKMPT,BKMODX,BKMNDX
+12 QUIT
MAIL ;
+1 ;XMDF=FLAG that programmer interface is in use. Set & killed here only.
+2 ; Therefore do not check for Security Keys on domains.
+3 ;XMSUB=HEADER
+4 ;XMTEXT=@LOCATION OF MESSAGE
+5 ;XMSTRIP=CHARACTERS THAT USER WANTS STRIPPED FROM TEXT OF MESSAGE
+6 ;XMDTEST=Testing Flag / in test mode if $G(XMDTEST)=1
+7 ;XMDUZ=SENDER #
+8 ;I $D(XMMG),'$D(XMY) XMMG WILL BE THE DEFAULT FOR THE FIRST SEND TO:
+9 ;XMY I '$D(XMY) RECIPIENTS WILL BE PROMPTED FOR
+10 DO ^XMD
+11 QUIT
+12 ;
ETIXHLP ; EP - Executable help for Etiology field
+1 NEW BKMMN,BKMIEN,BKMDATA,BKMCNT,DUOUT,BKMRD
+2 DO EN^DDIOL("Choose from:","","!,?3")
+3 SET BKMMN=""
SET BKMCNT=0
+4 FOR
SET BKMMN=$ORDER(^BKM(90451.5,"D",BKMMN))
IF BKMMN=""
QUIT
Begin DoDot:1
+5 SET BKMIEN=0
+6 FOR
SET BKMIEN=$ORDER(^BKM(90451.5,"D",BKMMN,BKMIEN))
IF BKMIEN=""
QUIT
Begin DoDot:2
+7 SET BKMDATA=$GET(^BKM(90451.5,BKMIEN,0))
IF BKMDATA=""
QUIT
+8 SET BKMCNT=BKMCNT+1
+9 DO EN^DDIOL($$PAD^BKMIXX4($PIECE(BKMDATA,U,2),">"," ",10)_$EXTRACT($PIECE(BKMDATA,U,1),1,70),"","!,?3")
+10 IF BKMCNT=10
Begin DoDot:3
+11 IF $$PAUSE^BKMIXX3
SET DUOUT=1
QUIT
+12 ;R !,"'^' TO STOP: ",BKMRD:DTIME S:'$T BKMRD=U
+13 ;I BKMRD[U S DUOUT=1 Q
+14 SET BKMCNT=0
End DoDot:3
IF $GET(DUOUT)
QUIT
End DoDot:2
IF $GET(DUOUT)
QUIT
End DoDot:1
IF $GET(DUOUT)
QUIT
+15 ; Reset DV to "" to prevent generic help from displaying
+16 SET DV=""
+17 QUIT
+18 ;
XIT ;EXIT THE LOOKUP PROCEDURE
+1 KILL BKMNEW,DIC,DIE,X,Y,DA,BKMID,BKMH3,BKMH2,BKMID,BKMLOC,BKMH1
