source: FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBUTL1.m

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.
 ;
 ; Reference/IA
 ; INP^VADPT/10061
 ; DIC(42/10039
 ; DIC(42/2440
 ;
ERRBLD(SEG,MSG,ERR) ; build an error array for non-FileMan-related errors...
 ; SEG = HL7 segment name
 ; MSG = a message that will be used in the error text portion of the array (optional -- if not passed, the
 ;       default will be used)
 ; ERR = array passed by reference in which error will be returned
 ; note:  code 999 is a code indicating a non-FileMan error for filing the error message in file 53.71
 S ERR("DIERR")=1
 S ERR("DIERR",1)=999
 S ERR("DIERR",1,"TEXT",1)=$S($G(MSG)'="":MSG,1:"Invalid parameter passed to "_SEG_" module in routine ALPBHL1U")
 Q
 ;
ERRLOG(IEN,OIEN,MSGREC,SEGNAME,SEGDATA,ERRTEXT) ; log filing errors...
 ; this module logs error data in the BCMA BACKUP PARAMETERS file (53.71).  These
 ; errors usually occur as the result of missing or bad data passed to one of the
 ; File Manager DBS calls used by this package.
 ; 
 ; IEN       = the patient's record number in file 53.7
 ; OIEN      = the order number's sub-file record number in file 53.7
 ; MSGREC    = the HL7 message's record number in file 772
 ; SEGNAME   = the HL7 segment associated with the error (optional)
 ; SEGDATA   = the HL7 segment's data (optional)
 ; ERRTEXT   = an array passed by reference which contains the error
 ;             code (numeric) and the error text to be filed.  It is
 ;             expected that this is usually the error array returned
 ;             from a FileMan DBS call, so the format is specific:
 ;
 ;             ERRTEXT("DIERR",n)=error code (numeric)
 ;             ERRTEXT("DIERR",n,"TEXT",1)=first line of error text
 ;             ERRTEXT("DIERR",n,"TEXT",2)=second line of error text
 ;             ERRTEXT("DIERR",n,"TEXT",n)=last line of error text
 ;
 ;             However, any error message can be passed to this module
 ;             as long as the above format is used.
 N ALPBCODE,ALPBFERR,ALPBFILE,ALPBLOGD,ALPBN1,ALPBN2,ALPBPIEN,ALPBTEXT,ALPBX
 S ALPBLOGD=$$NOW^XLFDT()
 S ALPBPIEN=+$O(^ALPB(53.71,0))
 I ALPBPIEN=0 D
 .S X="ONE"
 .S DIC="^ALPB(53.71,"
 .S DIC(0)="LZ"
 .S DIC("DR")="1///^S X=3"
 .S DINUM=1
 .S DLAYGO=53.71
 .D FILE^DICN K DIC
 .S ALPBPIEN=+Y
 I ALPBPIEN'>0 Q
 S ALPBN1=+$O(^ALPB(53.71,ALPBPIEN,1," "),-1)+1
 S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",.01)=ALPBLOGD
 S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",1)=+$G(IEN)
 S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",2)=+$G(OIEN)
 S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3)=+$G(MSGREC)
 S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3.1)=$G(SEGNAME)
 S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3.2)=$G(SEGDATA)
 D UPDATE^DIE("","ALPBFILE","ALPBN1","ALPBFERR")
 K ALPBFERR,ALPBFILE
 S ALPBX=0
 F  S ALPBX=$O(ERRTEXT("DIERR",ALPBX)) Q:'ALPBX  D
 .S ALPBCODE=ERRTEXT("DIERR",ALPBX)
 .; file the error code...
 .S ALPBN2=+$O(^ALPB(53.71,ALPBPIEN,1,ALPBN1,2," "),-1)+1
 .S ALPBFILE(53.7135,"+"_ALPBN2_","_ALPBN1_","_ALPBPIEN_",",.01)=ALPBCODE
 .D UPDATE^DIE("","ALPBFILE","ALPBN2","ALPBFERR")
 .K ALPBFERR,ALPBFILE
 .; file the error text...
 .M ALPBTEXT=ERRTEXT("DIERR",ALPBX,"TEXT")
 .D WP^DIE(53.7135,ALPBN2_","_ALPBN1_","_ALPBPIEN_",",1,"","ALPBTEXT","ALPBFERR")
 .;S ALPBFILE(53.7135,"+"_ALPBN2_","_ALPBN1_","_ALPBPIEN_",",1)=ALPBTEXT
 .;D UPDATE^DIE("","ALPBFILE","ALPBN2","ALPBFERR")
 .K ALPBCODE,ALPBFERR,ALPBFILE,ALPBN2,ALPBTEXT
 Q
 ;
CLEAN(IEN) ; check error log records to see if the patients' whose records
 ; are noted still exist in file 53.7.  if not, delete the error log
 ; record(s) in file 53.71...
 ; IEN = patient record number in file 53.7
 ; Note:  this function is also called from DELPT^ALPBUTL when a patient's
 ; record is deleted (as a result of a discharge action) from 53.7.
 ;
 N ALPBX,ALPBY,DA,DIK,X,Y
 ; patient still has record in 53.7?  if so, quit...
 I $G(^ALPB(53.7,IEN,0))'="" Q
 S ALPBX=0
 F  S ALPBX=$O(^ALPB(53.71,"C",IEN,ALPBX)) Q:'ALPBX  D
 .S ALPBY=0
 .F  S ALPBY=$O(^ALPB(53.71,"C",IEN,ALPBX,ALPBY)) Q:'ALPBY  D
 ..S DA=ALPBY
 ..S DA(1)=ALPBX
 ..S DIK="^ALPB(53.71,"_DA(1)_",1,"
 ..D ^DIK
 ..K DA,DIK
 .K ALPBY
 K ALPBX
 Q
 ;
DELERR(ERRIEN) ; delete an error log entry from file 53.71...
 ; ERRIEN = error log entry's internal record number
 N ALPBPARM,DA,DIK,X,Y
 S ALPBPARM=+$O(^ALPB(53.71,0))
 I ALPBPARM'>0 Q
 S DA=ERRIEN
 S DA(1)=ALPBPARM
 S DIK="^ALPB(53.71,"_DA(1)_",1,"
 D ^DIK
 Q
 ;
PTLIST(LTYPE,RESULTS) ; get list of patients in file 53.7...
 ; LTYPE   = passed = "ALL" to list all patients or
 ;                  = <wardname> to list patients on a selected ward
 ; RESULTS = an array passed by reference in which data will be returned
 N ALPBDATA,ALPBIEN,ALPBPTN,ALPBX
 I $G(LTYPE)="" S LTYPE="ALL"
 S ALPBX=0
 I LTYPE="ALL" D
 .S ALPBPTN=""
 .F  S ALPBPTN=$O(^ALPB(53.7,"B",ALPBPTN)) Q:ALPBPTN=""  D
 ..S ALPBIEN=0
 ..F  S ALPBIEN=$O(^ALPB(53.7,"B",ALPBPTN,ALPBIEN)) Q:'ALPBIEN  D
 ...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,0))
 ...I ALPBDATA="" K ALPBDATA Q
 ...S ALPBX=ALPBX+1
 ...S RESULTS(ALPBX)=ALPBPTN_"^"_$P(ALPBDATA,"^",2)_"^"_$P(ALPBDATA,"^",5)_"^"_$P(ALPBDATA,"^",6)_"^"_$P(ALPBDATA,"^",7)
 ...K ALPBDATA
 ..K ALPBIEN
 .K ALPBPTN
 I LTYPE'="ALL" D
 .S ALPBPTN=""
 .F  S ALPBPTN=$O(^ALPB(53.7,"AW",LTYPE,ALPBPTN)) Q:ALPBPTN=""  D
 ..S ALPBIEN=0
 ..F  S ALPBIEN=$O(^ALPB(53.7,"AW",LTYPE,ALPBPTN,ALPBIEN)) Q:'ALPBIEN  D
 ...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,0))
 ...I ALPBDATA="" K ALPBDATA Q
 ...S ALPBX=ALPBX+1
 ...S RESULTS(ALPBX)=ALPBPTN_"^"_$P(ALPBDATA,"^",2)_"^"_$P(ALPBDATA,"^",5)_"^"_$P(ALPBDATA,"^",6)_"^"_$P(ALPBDATA,"^",7)
 ...K ALPBDATA
 ..K ALPBIEN
 .K ALPBPTN
 Q
 ;
STAT(ST) ;This will return the value of a status code for pharmacy
 I $G(ST)="" Q ""
 I $L($T(@ST)) G @ST
 Q ""
IP Q "pending"
CM Q "finished/verified by pharmacist(active)"
DC Q "discontinued"
RP Q "replaced"
HD Q "on hold"
ZE Q "expired"
ZS Q "suspended(active)"
ZU Q "un-suspended(active)"
ZX Q "unreleased"
ZZ Q "renewed"
 ;
STAT2(CODE) ; convert order status code for output...
 ; this function is used primarily by the workstation software
 ; CODE = an order status code
 ; returns printable status code
 I $G(CODE)="" Q "Unknown"
 I CODE="IP"!(CODE="ZX") Q "Pending"
 I CODE="CM"!(CODE="ZU")!(CODE="ZZ") Q "Active"
 I CODE="HD"!(CODE="ZS") Q "Hold"
 I CODE="DC"!(CODE="RP")!(CODE="ZE") Q "Expired"
 Q "Unknown"
 ;
DIV(DFN,ALPBMDT) ;get the Division for a patient
 I +$G(DFN)'>0 Q ""
 N ALPBDIV,ALPWRD,VAIN,VAINDT
 S:+$G(ALPBMDT)>0 VAINDT=$P(ALPBMDT,".",1)
 K ALPBMDT
 D INP^VADPT
 S ALPWRD=$P($G(VAIN(4)),U,1)
 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"
 S ALPBDIV=$P($G(^DIC(42,ALPWRD,0)),U,11)
 Q:+ALPBDIV'>0 ""
 Q ALPBDIV
 ;
CNV(A,B,X) ;CONVERT A STRING
 ;This API will take a HL7 segment and convert characters
 ;defined in the input
 ;Example:
 ;Single encoding characters can be converted such as ^ to ~
 ;or multiple encoding characters can be converted such as
 ;  |~^@/ to ^~|/@
 ;A is the string of HL7 encoding characters to be converted
 ;B is the string of HL7 encoding characters to be converted to
 ;X is te message string to be converted
 I A=""!B=""!X="" Q ""
 F I=1:1:$L(A) S A(I)=$E(A,I,I),A(I,1)=""
 F I=1:1:$L(B) S B(I)=$E(B,I,I)
 S J=0
 F  S J=$O(A(J)) Q:+J'>0  D
 . F I=1:1:$L(X) S:$E(X,I,I)=A(J) A(J,1)=A(J,1)_I_U
 S J=0
 F  S J=$O(A(J)) Q:+J'>0  D
 . Q:'$D(A(J,1))!'$D(B(J))
 . F I=1:1:$L(A(J,1),U) S C=$P(A(J,1),U,I) S:+C>0 $E(X,C,C)=B(J)
 Q X