Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BKMILK

BKMILK.m

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