Changeset 636 for FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB

Timestamp:

Dec 4, 2009, 8:26:01 PM (14 years ago)

Author:

George Lilly

Message:

WorldVistAEHR overlayed on FOIAVistA

Location:

FOIAVistA/tag/r

Files:

• . (copied) (copied from FOIAVistA/trunk/r )
• BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBGEN1.m (modified) (2 diffs)
• BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBINP.m (modified) (6 diffs)
• BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBPWRD.m (modified) (2 diffs)
• BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBUTL1.m (modified) (2 diffs)
• BAR_CODE_MED_ADMIN-ALPB-PSB/PSBO.m (modified) (2 diffs)
• BAR_CODE_MED_ADMIN-ALPB-PSB/PSBO1.m (modified) (2 diffs)
• BAR_CODE_MED_ADMIN-ALPB-PSB/PSBOMH1.m (modified) (2 diffs)
• BAR_CODE_MED_ADMIN-ALPB-PSB/PSBPOIV.m (modified) (3 diffs)
• BAR_CODE_MED_ADMIN-ALPB-PSB/PSBRPC2.m (modified) (3 diffs)

FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBGEN1.m

@@ -1 @@
-ALPBGEN1 ;SFVAMC/JC - Parse and File HL7 PMU messages ;05/10/07
- ;;3.0;BAR CODE MED ADMIN;**8,37**;Mar 2004;Build 10
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ALPBGEN1 ;SFVAMC/JC - Parse and File HL7 PMU messages ;04/30/2003  07:59
+ ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
  Q
  ;
@@ -45 +44 @@
  ;If SSN lookup fails, try name lookup and add
  I +Y<1 S DLAYGO=200,DIC="^VA(200,",DIC(0)="LM",X=ALPBNAM D ^DIC K DIC,DA,DR
- I +Y>0 S (ALPBDA,DA,DUZ)=+Y S ALPBMENU=$O(^DIC(19,"B","PSB BCBU WRKSTN MAIN",0)) D
+ I +Y>0 S (ALPBDA,DA)=+Y S ALPBMENU=$O(^DIC(19,"B","PSB BCBU WRKSTN MAIN",0)) D
  . S DIE="^VA(200,",DR="2////^S X=ALPBAC"
  . ;Update name too

FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBINP.m

@@ -1 +1 @@
 ALPBINP ;OIFO-DALLAS/SED/KC/MW  BCMA - BCBU INPT TO HL7 ;5/2/2002
- ;;3.0;BAR CODE MED ADMIN;**8,37**;May 2007;Build 10
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
  ;This routine will intercept the HL7 message that it sent from Pharmacy
  ;to CPRS to update order information. The message is then parsed and 
@@ -46 +45 @@
  D EN^PSJBCBU(ALPDFN,ALPORD,.ALPB)
 SEED ;Entry point for ^ALPBIND
- N VAIN
  D INIT
  S SUB=0 F  S SUB=$O(ALPB(SUB)) Q:'SUB  D
@@ -67 +65 @@
  ;Get the Division that the patient is associated with
  D PDIV
- I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "0^^Screen of DOMICILIARY"
+ I ALPDIV="DOM" Q "0^^Screen of DOMICILIARY"
  I '$D(HLL("LINKS")) Q "0^HL7^Missing HLL Links Array Division # "_ALPDIV
  ;SET NEW PV1
@@ -144 +142 @@
  S ALPDIV=$$DIV^ALPBUTL1(ALPDFN,ALPBMDT)
  ;Screen Dom
- I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q
+ Q:ALPDIV="DOM"
  ;Now do I send the Message or not Based of Division
  I $D(ALPHLL("LINKS")) M HLL("LINKS")=ALPHLL("LINKS")
@@ -161 +159 @@
  ;Get the Division that the patient is associated with
  D PDIV
- I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "0^^Screen of DOMICILIARY"
+ I ALPDIV="DOM" Q "0^^Screen of DOMICILIARY"
  I '$D(HLL("LINKS")) Q "0^"_ALPML_"^Missing HLL Links Array Med-Log"
  S ALPST=$P($G(^PSB(53.79,ALPML,0)),U,9)
@@ -202 +200 @@
  ;Get the Division that the patient is associated with
  D PDIV
- I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "0^^Screen of DOMICILIARY"
+ I ALPDIV="DOM" Q "0^^Screen of DOMICILIARY"
  I '$D(HLL("LINKS")) Q "0^"_ALPDFN_"^Missing HLL Links Array Pat-Move"
  S HLA("HLS",1)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")

FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBPWRD.m

@@ -1 +1 @@
 ALPBPWRD ;OIFO-DALLAS MW,SED,KC-PRINT 3-DAY MAR BCMA BCBU REPORT FOR A SELECTED WARD ;01/01/03
- ;;3.0;BAR CODE MED ADMIN;**8,37**;Mar 2004;Build 10
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
  ; 
  ; NOTE: this routine is designed for hard-copy output.
@@ -144 +143 @@
  I ALPBSORT="R" D
  .S ALPBD="",ALPRM=""
- .F  S ALPBPTN=$O(^TMP($J,ALPBPTN)) Q:ALPBPTN=""  D  Q:ALPBPTN=""
+ .F  S ALPBPTN=$O(^TMP($J,ALPBPTN)) Q:ALPBPTN=""  D 
  ..I ALPBPTN="BCBU" S ALPBPTN=$O(^TMP($J,ALPBPTN)) ;SKIP "BCBU" SUBSCRIBE
- ..I ALPBPTN="" Q  ;PSB*3*37 Stop null subscript when "BCBU" is the last entry in ^TMP
  ..S ALPBIEN=^TMP($J,ALPBPTN) S ALPRM=$P($G(^ALPB(53.7,ALPBIEN,0)),"^",6),ALPBD=$P($G(^ALPB(53.7,ALPBIEN,0)),"^",7)
  ..I ALPBD="" S ALPB="NONE" I ALPRM="" S ALPB="NONE" ;INCASE NO ROOM AND BED YET

FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBUTL1.m

@@ -1 +1 @@
 ALPBUTL1 ;OIFO-DALLAS MW,SED,KC-BCBU BACKUP REPORT FUNCTIONS AND UTILITIES  ;01/01/03
- ;;3.0;BAR CODE MED ADMIN;**8,37**;Mar 2004;Build 10
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
  ;
  ; Reference/IA
@@ -181 +180 @@
  Q:+ALPWRD'>0 ""
  ;Check to see if ward is a DOMICILIARY 
- I $P($G(^DIC(42,ALPWRD,0)),U,3)="D",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "DOM"
+ I $P($G(^DIC(42,ALPWRD,0)),U,3)="D" Q "DOM"
  S ALPBDIV=$P($G(^DIC(42,ALPWRD,0)),U,11)
  Q:+ALPBDIV'>0 ""

FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBO.m

@@ -1 +1 @@
 PSBO ;BIRMINGHAM/EFC-BCMA OUTPUTS ;Mar 2004
- ;;3.0;BAR CODE MED ADMIN;**13,32,2**;Mar 2004;Build 22
+ ;;3.0;BAR CODE MED ADMIN;**13,32**;Mar 2004;Build 32
  ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
  ; Reference/IA
@@ -71 +71 @@
  D:PSBSAVE
  .;Check Drug to Patient Relationship.
- .I (PSBTYPE="BL")!(PSBTYPE="BZ") S PSBANS="" D CHECK  I PSBANS=0!($D(DIRUT)) W !,"Cancelling Request..." S DIK="^PSB(53.69," D ^DIK W "Cancelled!" Q
+ .I PSBTYPE="BL" S PSBANS="" D CHECK  I PSBANS=0!($D(DIRUT)) W !,"Cancelling Request..." S DIK="^PSB(53.69," D ^DIK W "Cancelled!" Q
  .;
  .;Allow "'BROWSER" Device

FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBO1.m

@@ -1 +1 @@
 PSBO1 ;BIRMINGHAM/EFC-BCMA OUTPUTS ;Mar 2004
- ;;3.0;BAR CODE MED ADMIN;**4,13,32,2**;Mar 2004;Build 22
+ ;;3.0;BAR CODE MED ADMIN;**4,13,32**;Mar 2004;Build 32
  ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
  ; Reference/IA
@@ -9 +9 @@
  K RESULTS
  ; Check Type
- I '$F("DL^MD^MH^ML^MM^MV^MT^PE^PM^WA^BL^PI^AL^DO^VT^PF^XA^IV^CM^CP^CE^CI^BZ^",PSBRTYP) S RESULTS(0)="-1^Invalid Report Type" Q
+ I '$F("DL^MD^MH^ML^MM^MV^MT^PE^PM^WA^BL^PI^AL^DO^VT^PF^XA^IV^CM^CP^CE^CI^",PSBRTYP) S RESULTS(0)="-1^Invalid Report Type" Q
  I '+$G(DUZ) S RESULTS(0)="-1^Undefined User" Q
  I '$G(DUZ(2)) S RESULTS(0)="-1^Undefined Division" Q
  ; Lock Log
- L +(^PSB(53.69,0)):$S($G(DILOCKTM)>0:DILOCKTM,1:3)
+ L +(^PSB(53.69,0)):0
  E  S RESULTS(0)="-1^Request Log Locked" Q
  ; Generate Unique Entry and Create

FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBOMH1.m

@@ -1 @@
-PSBOMH1 ;BIRMINGHAM/EFC-MAH ;Mar 2004
- ;;3.0;BAR CODE MED ADMIN;**6,3,9,11,26,38**;Mar 2004;Build 8
+PSBOMH1 ;BIRMINGHAM/EFC-MAH ;7:40 PM  30 Jan 2008
+ ;;3.0;BAR CODE MED ADMIN;**6,3,9,11,26,38,VWEHR1**;WorldVistA 30-Jan-08
  ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  ;
  ; Reference/IA
@@ -123 +141 @@
  I PSBGA'=1 S PSBTMP(10000000-$P(PSBMLA(0),U,6),"A")=$P(PSBMLA(0),U,6)_U_$$INITIAL^PSBRPC2($P(PSBMLA(0),U,7))
  S PSBQRY="PSBTMP",PSBCNT=1 F  S PSBQRY=$Q(@PSBQRY) Q:PSBQRY=""  D  ; does comment go with action
- .S PSBPQRY=$Q(@PSBQRY,-1)
+ .;
+ .;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
+ .;
+ .;S PSBPQRY=$Q(@PSBQRY,-1)
+ .S PSBPQRY=$$Q^VWUTIL($NA(@PSBQRY),-1)
+ .;
+ .;END CHANGE
+ .;
  .I PSBPQRY="" S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q  ; no prev action
  .I $QS(PSBPQRY,2)="C"  S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q  ; prev line = comment

FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBPOIV.m

@@ -1 +1 @@
 PSBPOIV ;BIRMINGHAM/EFC-IV PARAMETER VALIDATION ;Mar 2004
- ;;3.0;BAR CODE MED ADMIN;**2**;Mar 2004;Build 22
- ;;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+ ;;3.0;BAR CODE MED ADMIN;;Mar 2004
  ;
  ; Reference/IA
+ ; ^DIC(42/1377
  ; ^DIC(42/2440
+ ; EN^PSJCBMA1/2829
  ; EN^PSJBCMA2/2830
- ; VADPT/10061
- ;
+ ; DIQ(2/10035
  ;
 EN(PSBDFN,PSBORD) ;
@@ -16 +16 @@
  ; get IV parameters for the current ward
  S PSBCSTR="^ADDITIVE^STRENGTH^BOTTLE^SOLUTION^VOLUME^INFUSION RATE^MED ROUTE^SCHEDULE^ADMIN TIME^REMARKS^OTHER PRINT INFO^PROVIDER^START DATE/TIME^STOP DATE/TIME^PROVIDER COMMENTS"
- D INP^VADPT S PSBWARD=$P(VAIN(4),"^"),PSBWDIV=PSBWARD D KVAR^VADPT
+ S PSBWARD=$$GET1^DIQ(2,PSBDFN_",",.1),PSBWARD=$$FIND1^DIC(42,"","X",PSBWARD),PSBWDIV=PSBWARD
  I $G(PSBWARD)'="",$D(^PSB(53.66,"B",PSBWARD)) D  ; if IV paramaters defined for ward use them
  .S PSBWARD=$O(^PSB(53.66,"B",PSBWARD,""))
@@ -22 +22 @@
  I '$D(PSBIVPAR) S PSBIVPAR=PSBIVT D  ; if IV parameters not defined for ward get defaults for division
  .D:$D(PSBWDIV)  ; Get the appropriate DIV for ward and DIVISIONAL IV PARAMETERS
- ..S PSBWDIV=$$GET1^DIQ(42,PSBWDIV_",",.015,"I")
+ ..S PSBWDIV=$$GET1^DIQ(42,PSBWDIV_",",.015,"I"),PSBWDIV=$P($$SITE^VASITE(DT,PSBWDIV),U,1)
  ..I $G(PSBWDIV)']"" S PSBWDIV="DIV"
- ..E  S PSBWDIV=$P($$SITE^VASITE(DT,PSBWDIV),U,1),PSBWDIV="DIV.`"_PSBWDIV
+ ..E  S PSBWDIV="DIV.`"_PSBWDIV
  ..F X=2:1 Q:$P(PSBCSTR,U,X)=""  S PSBIVPAR=PSBIVPAR_U_$P($P($$GET^XPAR(PSBWDIV,"PSBIV "_$P(PSBCSTR,U,X),PSBIVT,"B"),U,2),"-",1)
  ..K PSBWDIV ; Kill temp variable.

FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBRPC2.m

@@ -1 @@
-PSBRPC2 ;BIRMINGHAM/EFC-BCMA RPC BROKER CALLS ;Mar 2004
- ;;3.0;BAR CODE MED ADMIN;**6,3,16,32**;Mar 2004;Build 32
+PSBRPC2 ;BIRMINGHAM/EFC-BCMA RPC BROKER CALLS ;7:42 PM  30 Jan 2008
+ ;;3.0;BAR CODE MED ADMIN;**6,3,16,32,WVEHR1**;WorldVistA 30-Jan-08
  ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+ ;
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  ;
  ; Reference/IA
@@ -54 +72 @@
  Q
  ;
-BAGDTL(RESULTS,PSBUID,PSBORD)  ; bag detail
+BAGDTL(RESULTS,PSBUID,PSBORD) ; bag detail
  I $G(DFN)="" S DFN=+PSBUID
  S (PSBIEN,X)="" F  S X=$O(^PSB(53.79,"AUID",DFN,X)) Q:X=""  S:$D(^PSB(53.79,"AUID",DFN,X,PSBUID)) PSBIEN=$O(^PSB(53.79,"AUID",DFN,X,PSBUID,"")) Q:PSBIEN]""
@@ -85 +103 @@
 INITIAL(PSBDUZ) ;
  Q $$GET1^DIQ(200,PSBDUZ,"INITIAL")
-SCANMED(RESULTS,PSBDIEN,PSBTAB)  ; Lookup Medication
+SCANMED(RESULTS,PSBDIEN,PSBTAB) ; Lookup Medication
  ;
  ; RPC: PSB SCANMED