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

BLRPR27P.m

Go to the documentation of this file. 
  1. BLRPR27P ;IHS/OIT/MKK - IHS Lab PATCH 1027 Post Install Routine ;JUL 06, 2010 3:14 PM
  1.  ;;5.2;IHS LABORATORY;**1027**;NOV 01, 1997
  1.  ;
  1.  Q
  1.  ;
  1. EP ; EP
  1.  D EEP^BLRGMENU
  1.  Q
  1.  ;
  1. ADDEAGDC ; EP -- Add Estimated Average Glucose (EAG) to Delta Check dictionary
  1.  NEW DESC,DESC1STR,DESC2STR,NAME,OVER1,OVER1STR,XCODE,XCODESTR
  1.  NEW A1CIEN,A1CDESC,MESSAGE,TARGET
  1.  ;
  1.  ;
  1.  D MKDELTA("HEMOGLOBIN A1C","ESTIMATED AVERAGE GLUCOSE","Created by IHS Lab Patch 1027")
  1.  Q
  1.  ;
  1. MKDELTA(F60TEST1,F60TEST2,FRMWHERE) ; EP
  1.  NEW EAGDNAME
  1.  S XCODESTR="S %X="""" X:$D(LRDEL(1)) LRDEL(1) W:$G(%X)'="""" ""  ESTIMATED AVERAGE GLUCOSE:"",$P(%X,""^"") S:LRVRM>0 LRSB($$GETDNAM^BLREXECU("""_F60TEST2_"""))=%X K %,%X,%Y,%Z,%ZZ"
  1.  S OVER1STR="S %ZZ=$$GETDNAM^BLREXECU("""_F60TEST1_""") X:LRVRM>0 ""F %=%ZZ S %X(%)=$S(%=LRSB:X,$D(LRSB(%)):+LRSB(%),1:0)"" X:LRVRM>0 ""F %=%ZZ S %X(%)=$S($D(LRSB(%)):LRSB(%),1:0)"" S %X=$FN((((X)*28.7)-46.7),"""",0)"
  1.  S OVER1STR=OVER1STR_"_""^^!!!!!!^^!!!!!!mg/dl!!^^^^""_$G(DUZ(2))"
  1.  ;
  1.  S NAME="EAG"
  1.  S EAGDNAME=$$GETDNAM^BLREXECU(F60TEST2)
  1.  S EAGDNAME=$P($G(^DD(63.04,EAGDNAME,0)),"^")
  1.  S XCODE=XCODESTR
  1.  S OVER1=OVER1STR
  1.  S DESC(1)="This delta check, when added to the A1C test, will calculate an Estimated"
  1.  S DESC(2)="Average Glucose (EAG) using the equation: EAG=((A1C)*28.7)-46.7.  It will"
  1.  S DESC(3)="stuff the result into the "_EAGDNAME_" Location (Data Name)."
  1.  D DLTADICA(NAME,XCODE,OVER1,.DESC,FRMWHERE)
  1.  ;
  1.  Q
  1.  ;
  1. DLTADICA(NAME,XCODE,OVER1,DESC,FRMWHERE) ; EP
  1.  NEW DICT0,DICT1,FDA,ERRS,PTR
  1.  NEW HEREYAGO
  1.  ;
  1.  D BMES^XPDUTL("Adding "_NAME_" to Delta Check Dictionary")
  1.  ;
  1.  D ^XBFMK
  1.  K ERRS,FDA,IENS,DIE
  1.  ; 
  1.  S DICT1="62.1"
  1.  S FDA(DICT1,"?+1,",.01)=NAME   ; Find the Name node, or create it.
  1.  S FDA(DICT1,"?+1,",10)=XCODE   ; Execute Code
  1.  S FDA(DICT1,"?+1,",20)=OVER1   ; Overflow 1
  1.  D UPDATE^DIE("S","FDA",,"ERRS")
  1.  ;
  1.  I $D(ERRS("DIERR"))>0 D  Q
  1.  . D SORRY^BLRPRE27("Error in adding "_NAME_" to the Delta Check Dictionary.","NONFATAL")
  1.  ;
  1.  D OKAY^BLRKIDSU(NAME_" Delta Check added to Delta Check Dictionary.",5)
  1.  ;
  1.  ; Now, add the Description
  1.  K ERRS
  1.  D FIND^DIC(62.1,"","","",NAME,"","","","","HEREYAGO") ; Get Pointer
  1.  S PTR=$G(HEREYAGO("DILIST",2,1))
  1.  M WPARRAY("WP")=DESC
  1.  D WP^DIE(62.1,PTR_",",30,"K","WPARRAY(""WP"")","ERRS")
  1.  ;
  1.  I $D(ERRS("DIERR"))>0 D  Q
  1.  . D SORRY^BLRPRE27("Error in adding DESCRIPTION to "_NAME_" Delta Check in the Delta Check Dictionary.","NONFATAL")
  1.  ;
  1.  D OKAY^BLRKIDSU(NAME_" Delta Check DESCRIPTION added to Delta Check Dictionary.",5)
  1.  ;
  1.  ; Now, add the SITE NOTES DATE
  1.  K ERRS,FDA
  1.  S FDA(62.131,"?+1,"_PTR_",",.01)=$P($$NOW^XLFDT,".",1)
  1.  D UPDATE^DIE("S","FDA",,"ERRS")
  1.  ;
  1.  I $D(ERRS("DIERR"))>0 D  Q
  1.  . D SORRY^BLRPRE27("Error in adding SITES NOTES DATE to "_NAME_" Delta Check in the Delta Check Dictionary.","NONFATAL")
  1.  ;
  1.  ; Now, add the TEXT
  1.  K ERRS,WPARRAY
  1.  S WPARRAY("WP",1)=FRMWHERE
  1.  D WP^DIE(62.131,"1,"_PTR_",",1,"K","WPARRAY(""WP"")","ERRS")
  1.  ;
  1.  I $D(ERRS("DIERR"))>0 D  Q
  1.  . D SORRY^BLRPRE27("Error in adding TEXT to "_NAME_" Delta Check in the Delta Check Dictionary.","NONFATAL")
  1.  ;
  1.  D OKAY^BLRKIDSU(NAME_" Delta Check TEXT added to Delta Check Dictionary.",5)
  1.  D BMES^XPDUTL(NAME_" Successfully Added to Delta Check Dictionary")
  1.  Q
  1.  ;
  1. TESTEAG(A1C) ; EP -- Interactive EAG Results
  1.  NEW EAG
  1.  I $G(A1C)="" D  Q
  1.  . W !,"Null A1C.  Routine Ends.",!
  1.  ;
  1.  S EAG=((A1C)*28.7)-46.7
  1.  W !,?4,"A1C = ",A1C,?19,"EAG = ",$FN(EAG,"",0),?34,"EAG with decimals=",EAG,!
  1.  Q
  1.  ;
  1. UCHOOSE ; EP - Allows User to select tests to use for EAG Delta Check
  1.  NEW DESC,DESC1STR,DESC2STR,NAME,OVER1,OVER1STR,XCODE,XCODESTR
  1.  NEW A1CIEN,A1CDESC,MESSAGE,TARGET
  1.  NEW A1CTEST,CUREAG,EAGTEST,HEADER,LINE,OUT,QFLAG
  1.  ;
  1.  S HEADER(1)="Estimated Average Glucose Delta Check Setup"
  1.  D HEADERDT^BLRGMENU
  1.  ;
  1.  ; Write Warning
  1.  S PKG="DLTAWARN"
  1.  F I=3:1 S X=$T(@PKG+I) Q:X["$$END"  D
  1.  . W $P(X,";",3),!
  1.  ;
  1.  D ^XBFMK
  1.  S DIR("A")="Continue (Y/N)"
  1.  S DIR(0)="Y"
  1.  D ^DIR
  1.  I +$G(Y)<1 D  Q
  1.  . W !,"YES not selected.  Routine ends.",!
  1.  . D PRESSKEY^BLRGMENU(10)
  1.  ;
  1.  K HEADER
  1.  S HEADER(1)="Estimated Average Glucose Delta Check"
  1.  S HEADER(2)="Re-Initialization"
  1.  S QFLAG=0
  1.  ;
  1.  ; Make sure user either ends the session or answers both test questions
  1.  F  Q:QFLAG!((+$G(A1CTEST)>0)&(+$G(EAGTEST)>0))  D
  1.  . D HEADERDT^BLRGMENU
  1.  . Q:$$GETF60("Enter HEMOGLOBIN A1C Test Name",.A1CTEST,.QFLAG)="Q"
  1.  . Q:$$GETF60("Enter Estimated Average Glucose Test Name",.EAGTEST,.QFLAG)="Q"
  1.  ;
  1.  Q:QFLAG
  1.  ;
  1.  K HEADER(2)
  1.  S HEADER(2)="Delete Current Estimated Average Glucose Delta Check"
  1.  D HEADERDT^BLRGMENU
  1.  W !,"The Current EAG will now be deleted.",!!
  1.  W ?5,"YES will delete the current EAG Delta Check.",!!
  1.  W ?5,"NO will stop the process.",!!
  1.  D ^XBFMK
  1.  S DIR("A")="Delete current EAG"
  1.  S DIR(0)="Y"
  1.  D ^DIR
  1.  I +$G(Y)<1 D
  1.  . W !!,"Current EAG Delta Check will *NOT* be deleted.  Routine ends.",!
  1.  . D PRESSKEY^BLRGMENU(10)
  1.  . S QFLAG=1
  1.  ;
  1.  Q:QFLAG
  1.  ;
  1.  ; Get IEN of current EAG Delta Check
  1.  D ^XBFMK
  1.  D FIND^DIC(62.1,,,,"EAG",,,,,"OUT")
  1.  S CUREAG=+$G(OUT("DILIST",2,1))
  1.  I CUREAG<1 D  Q
  1.  . W !!,"Could not find Current EAG Delta Check.  Routine ends.",!
  1.  . D PRESSKEY^BLRGMENU(10)
  1.  . S QFLAG=1
  1.  ;
  1.  Q:QFLAG
  1.  ;
  1.  ; Delete current EAG
  1.  D ^XBFMK
  1.  S DIK="^LAB(62.1,"
  1.  S DA=CUREAG
  1.  D ^DIK
  1.  ;
  1.  W !!,"Current EAG Deleted",!
  1.  D PRESSKEY^BLRGMENU(10)
  1.  ;
  1.  ; Create NEW EAG
  1.  K HEADER(2)
  1.  S HEADER(2)="Creating new EAG (Estimated Average Glucose) Delta Check"
  1.  D HEADERDT^BLRGMENU
  1.  W !
  1.  D MKDELTA($P(A1CTEST,"^",3),$P(EAGTEST,"^",3),"Interactively Created.")
  1.  ;
  1.  D PRESSKEY^BLRGMENU(10)
  1.  Q
  1.  ;
  1. GETF60(MSG,F60TEST,QFLAG) ; EP
  1.  NEW DATANAME,TESTDESC,TESTIEN
  1.  ;
  1.  S DATANAME=0
  1.  F  Q:DATANAME>1!(QFLAG)  D
  1.  . D HEADERDT^BLRGMENU
  1.  . D ^XBFMK
  1.  . S DIR(0)="P^60"
  1.  . S DIR("A")=MSG
  1.  . D ^DIR
  1.  . I +$G(DIRUT)>0!(+$G(Y)<1) D  Q
  1.  .. S QFLAG=1
  1.  .. W !,?5,"Exit Selected.  Routine ends.",!
  1.  .. D PRESSKEY^BLRGMENU(10)
  1.  . ;
  1.  . S TESTIEN=+$P($G(Y),"^")
  1.  . S TESTDESC=$P($G(Y),"^",2)
  1.  . S DATANAME=+$G(^LAB(60,+$G(Y),.2))
  1.  . I DATANAME<1 D
  1.  .. W !,?5,"Test ",TESTDESC," does NOT have a LOCATION (DATA NAME).",!!
  1.  .. D ^XBFMK
  1.  .. S DIR(0)="Y"
  1.  .. S DIR("A")="Try Again."
  1.  .. D ^DIR
  1.  .. I +$G(Y)<1 D
  1.  ... S QFLAG=1
  1.  ;
  1.  Q:QFLAG "Q"
  1.  ;
  1.  S F60TEST=$G(Y)_"^"_$P($G(^DD(63.04,DATANAME,0)),"^")
  1.  I 'QFLAG D
  1.  . S WOTNAME=$$TRIM^XLFSTR($P($P(MSG,"Enter",2),"Name"))
  1.  . W !!,?5,TESTDESC," (",TESTIEN,") selected as ",WOTNAME,".",!!
  1.  . D PRESSKEY^BLRGMENU(10)
  1.  ;
  1.  Q $S(QFLAG:"Q",1:"OK")
  1.  ;
  1. DLTAWARN ; EP -- Warning verbiage
  1.  ;;1234567890123456789012345678901234567890123456789012345678901234567890
  1.  ;;
  1.  ;;          This routine will allow a user to specify two tests from
  1.  ;;     the Laboratory Test File (# 60) that will be used to create a
  1.  ;;     new  Estimated Average Glucose (EAG) Delta Check in the Delta
  1.  ;;     Check File (# 62.1).
  1.  ;;     
  1.  ;;          Please note that this will  **DELETE**  the original EAG
  1.  ;;     Delta check that was created during the post-install phase of
  1.  ;;     IHS Lab Patch 1027.
  1.  ;;     
  1.  ;;$$END