ALPBUTL ;OIFO-DALLAS MW,SED,KC-BCMA BCBU REPORT FUNCTIONS AND UTILITIES ;2/28/13 8:13am
;;3.0;BAR CODE MED ADMIN;**8,73**;Mar 2004;Build 31
;
;*73 add logic to handle Clinic Orders (CO)
;
DEFPRT() ; fetch and return default printer...
; returns default printer entry from Device file based on entry in
; DEFAULT MAR PRINTER field in BCMA BACKUP PARAMETERS file (53.71)
N X
S X=+$O(^ALPB(53.71,0))
I X=0 Q ""
Q $P($G(^%ZIS(1,+$P(^ALPB(53.71,X,0),"^",3),0)),U)
;
DEFDAYS() ; fetch and return default days for MAR printing...
; returns default number of days to print MARs based on entry in
; DEFAULT DAYS FOR MAR field in BCMA BACKUP PARAMETERS file (53.71)
; if null or undefined, returns default of 3 (days)
N X
S X=+$O(^ALPB(53.71,0))
I X=0 Q 7
Q +$P(^ALPB(53.71,X,0),"^",2)
;
MLRANGE(IEN) ; find first and last Med Log entries' date/time...
; IEN = patient's record number in file 53.7
; returns a delimited string = first Med Log date/time^last Med Log date/time
N FIRST,LAST
S FIRST=$O(^ALPB(53.7,IEN,"AMLOG",""))
I FIRST="" Q "^"
S FIRST=FIRST\1
S LAST=$O(^ALPB(53.7,IEN,"AMLOG",""),-1)
I LAST'="" S LAST=LAST\1
I FIRST=LAST Q FIRST_"^"
Q FIRST_"^"_LAST
;
PAD(STRING,SPACES) ; pad a string...
; STRING = a string passed by reference
; SPACES = number of spaces to concatenate onto STRING
; returns STRING padded with SPACES number of blank spaces
N I,RESULT
I $G(STRING)="" S STRING=" "
I $G(SPACES)="" Q STRING
S RESULT=STRING F I=$L(RESULT):1:SPACES S RESULT=RESULT_" "
Q RESULT
;
FDAYS(START,DAYS,SPACE) ; format a sequence of DAYS beginning with START separated by SPACE...
; START = a date in FileMan internal format from which the formatted string will start
; DAYS = the number of consecutive days to return in the formatted string
; SPACE = the number of spaces between each number in the formatted string
; (if not passed, defaults to 4 spaces)
; returns a formatted string (example: 1 2 3)
N DIM,I,J,RESULT,TODAY
I $G(START)=""!($G(DAYS)="") Q ""
I $G(SPACE)="" S SPACE=4
S (RESULT,TODAY)=+$E(START,6,7)
F I=1:1:SPACE S RESULT=RESULT_" "
S DIM=$$DIM(START)
F I=DAYS-1:-1:1 D
.S TODAY=TODAY+1
.I TODAY>DIM S TODAY=1
.S RESULT=RESULT_$S(TODAY<10:"0"_TODAY,1:TODAY)
.I I>1 D
..F J=1:1:SPACE S RESULT=RESULT_" "
Q RESULT
;
FMONS(START,DAYS,SPACE) ; format a sequence of months given a START date separated by SPACE...
; START = a date in FileMan internal format the month of which will be the string starting point
; DAYS = the number of days that will be displayed
; SPACE = the number of spaces between each month (defaults to 1 space)
; returns a string equal to the month or months depending upon the number of days passed
; for example: if START=3021031 (Oct 31, 2002) and DAYS=3 then two month names will be
; returned: OCT NOV
N DIM,I,J,MON,MON1,NEXTMON,RESULT,TODAY,XSPACE
I $G(START)=""!($G(DAYS)="") Q ""
I $G(SPACE)="" S SPACE=4
S (XSPACE,XSTRIP)=""
F I=1:1:SPACE+1 S XSPACE=XSPACE_"*",XSTRIP=XSTRIP_" "
S DIM=$$DIM(START),TODAY=+$E(START,6,7),MON1=+$E(START,4,5)
S (RESULT,MON)=$$MONN(MON1)
I (TODAY+DAYS)<DIM!(TODAY+DAYS=DIM) Q RESULT
F I=1:1:DAYS D
.S RESULT=RESULT_XSPACE
.S TODAY=TODAY+1
.I TODAY<DIM!(TODAY=DIM) Q
.S MON1=MON1+1
.I MON1>12 S MON1=1
.S MON=$$MONN(MON1),RESULT=RESULT_MON
.S DIM=$$DIM($E(START,1,3)_$S(MON1<10:"0"_MON1,1:MON1)),TODAY=0
F I=$L(RESULT):-1 Q:$E(RESULT,I)'="*"!(I=0)
S RESULT=$E(RESULT,1,I),RESULT=$TR(RESULT,XSPACE,XSTRIP)
Q RESULT
;
FDATES(START,DAYS,RESULTS) ;
N I,X,X1,X2
S RESULTS(0)=" "_$E(START,4,5)_"/"_$E(START,6,7)_" ",RESULTS(1)=START
F I=1:1:DAYS-1 D
.S X1=START,X2=I
.D C^%DTC
.S RESULTS(I+1)=X,RESULTS(0)=RESULTS(0)_" "_$E(X,4,5)_"/"_$E(X,6,7)_" "
.K X,X1,X2
Q
;
DIM(X) ; number of days in a specified month...
; X = a date in internal FileMan format (can be partial: YYYMM)
; returns a number representing the number of days in month X
I $G(X)="" Q 0
N DAYS,MON,YEAR
S MON=+$E(X,4,5)
I MON<1 Q 0
S DAYS=$S(MON=1:31,MON=2:28,MON=3:31,MON=4:30,MON=5:31,MON=6:30,MON=7:31,MON=8:31,MON=9:30,MON=10:31,MON=11:30,MON=12:31,1:0)
; if passed date is in Feb, check for leap year and adjust days if needed...
I MON=2 D
.S YEAR=+$E(X,1,3)+1700
.I $$LEAP^XLFDT2(YEAR) S DAYS=29
Q DAYS
;
MONN(X) ; month name...
; X = month number (1-12)
; returns name of month specified in X
I $G(X)="" Q ""
S X=+X
Q $S(X=1:"JAN",X=2:"FEB",X=3:"MAR",X=4:"APR",X=5:"MAY",X=6:"JUN",X=7:"JUL",X=8:"AUG",X=9:"SEP",X=10:"OCT",X=11:"NOV",X=12:"DEC",1:"")
;
FDATE(X) ; special format for a FileMan date/time...
; X = date and time (time is optional) in FileMan format
; returns the FileMan date/time in the format MM/DD/YY@HH:MM
N DATE,FMDATE
S DATE=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
S FMDATE=$$FMTE^XLFDT(X)
I $P(FMDATE,"@",2)'="" S DATE=DATE_"@"_$P($P(FMDATE,"@",2),":")_":"_$P($P(FMDATE,"@",2),":",2)
Q DATE
;
WARDLIST(DTYPE) ; list of wards on file...
; DTYPE = 'C' for vertical (columnar) list
; 'L' for horizontal list
I $G(DTYPE)="" S DTYPE="L"
N ALPBWARD
W !,"Wards with BCMA Backup Data on this workstation:",!
S ALPBWARD=""
F S ALPBWARD=$O(^ALPB(53.7,"AW",ALPBWARD)) Q:ALPBWARD="" D
.I DTYPE="L" D Q
..I $X+$L(ALPBWARD)>IOM W !
..W ALPBWARD
..I $O(^ALPB(53.7,"AW",ALPBWARD))'="" W ", "
.W !?5,ALPBWARD
Q
;
WARDSEL(WARD,RESULTS) ; find a selected ward...
; WARD = a string representing a ward input by the user
; RESULTS = an array passed by reference in which possible matches are stored
; returns possible matches for the WARD in RESULTS
N ALPBWARD,ALPBX
S RESULTS(0)=0
S ALPBWARD=""
F S ALPBWARD=$O(^ALPB(53.7,"AW",ALPBWARD)) Q:ALPBWARD="" D
.I ALPBWARD=WARD D Q
..S RESULTS(0)=RESULTS(0)+1,RESULTS(RESULTS(0))=ALPBWARD
.I ALPBWARD[WARD D
..S RESULTS(0)=RESULTS(0)+1,RESULTS(RESULTS(0))=ALPBWARD
; if a straight lookup failed, let's try making any alphas
; entered by the user uppercase and try it once more...
I RESULTS(0)=0 D
.S WARD=$$UP^XLFSTR(WARD)
.S ALPBWARD=""
.F S ALPBWARD=$O(^ALPB(53.7,"AW",ALPBWARD)) Q:ALPBWARD="" D
..I ALPBWARD=WARD D Q
...S RESULTS(0)=RESULTS(0)+1,RESULTS(RESULTS(0))=ALPBWARD
..I ALPBWARD[WARD D
...S RESULTS(0)=RESULTS(0)+1,RESULTS(RESULTS(0))=ALPBWARD
Q
;
OTYP(CODE) ; expand order type for printing...
; CODE = a character representing an order type
; returns expanded order type from ^DD(53.79,6,0)
I $G(CODE)="" Q ""
Q $S(CODE="U":"UNIT DOSE",CODE="V":"IV",CODE="P":"PENDING",1:CODE)
;
ORDS(IEN,DATE,RESULTS,CO,INCLIM) ; retrieve orders for a given patient... *73
; IEN = patient's record number in file 53.7
; DATE = the date/time used to determine whether all or only current
; orders are returned:
; >passed as a date/time in FileMan internal format -- only orders
; with a stop date/time equal to or greater than DATE are returned
; >passed = "" then all orders are returned regardless of status
; returns RESULTS(order# ien) -- note: RESULTS(0)=count of active orders
; *73 add 2 new input varaibles below
; CO = Clinic name selected to match for return orders, if clinic
; report requested.
; INCLIM = Include IM orders for a CO report request. Y or N
;
S CO=$G(CO),INCLIM=$G(INCLIM) ;optional parameters
I +$G(IEN)=0 S RESULTS(0)=0 Q
N ALPBX,ALPBY,ORDERDAT,ORIEN,ORDERST,CLNAM
S (ORDERIEN,RESULTS(0))=0
F S ORDERIEN=$O(^ALPB(53.7,IEN,2,ORDERIEN)) Q:'ORDERIEN D
.S ORDERDAT(0)=$G(^ALPB(53.7,IEN,2,ORDERIEN,0))
.S ORDERDAT(1)=$G(^ALPB(53.7,IEN,2,ORDERIEN,1))
.S ORDERDAT(3)=$G(^ALPB(53.7,IEN,2,ORDERIEN,3))
.S ORDERDAT(4)=$G(^ALPB(53.7,IEN,2,ORDERIEN,4))
.S ORDERST=$P($P(ORDERDAT(0),"^",3),"~")
.; *73 add CO logic below
.S:CO]"" CLNAM=$P(ORDERDAT(0),U,5) ;is a Clinic report
.I CO]"",CLNAM]"",CO'=CLNAM K ORDERDAT Q ;skip, not selected CLIN
.I CO]"",CLNAM="",INCLIM="N" K ORDERDAT Q ;skip IM recs
.;
.; is this order current?...
.I $G(DATE)'=""&($P(ORDERDAT(1),"^",2)<$G(DATE)) K ORDERDAT Q
.; if current, is it still active?...
.I $G(DATE)'=""&(ORDERST'="CM")&(ORDERST'="ZS")&(ORDERST'="ZU") K ORDERDAT Q
.S RESULTS(0)=RESULTS(0)+1
.S RESULTS(ORDERIEN)=$P(ORDERDAT(0),"^")
.S RESULTS("B",$P(ORDERDAT(0),"^"))=ORDERIEN
.S RESULTS(ORDERIEN,1)=$S($P(ORDERDAT(3),"^")="V":"IV",$P(ORDERDAT(3),"^")="U":"UD",1:$P(ORDERDAT(3),"^"))
.S RESULTS(ORDERIEN,2)=ORDERST
.S RESULTS(ORDERIEN,3,0)=0
.;S RESULTS(ORDERIEN,4)=$P($G(ORDERDAT(4)),"^",3)
.S RESULTS(ORDERIEN,4)=$G(ORDERDAT(4))
.I +$O(^ALPB(53.7,IEN,2,ORDERIEN,7,0)) D
..S ALPBX=0
..F S ALPBX=$O(^ALPB(53.7,IEN,2,ORDERIEN,7,ALPBX)) Q:'ALPBX D
...S ALPBY=RESULTS(ORDERIEN,3,0)+1
...S RESULTS(ORDERIEN,3,ALPBY)=$P(^ALPB(53.7,IEN,2,ORDERIEN,7,ALPBX,0),"^",2)
...S RESULTS(ORDERIEN,3,0)=ALPBY
.I +$O(^ALPB(53.7,IEN,2,ORDERIEN,8,0)) D
..S ALPBX=0
..F S ALPBX=$O(^ALPB(53.7,IEN,2,ORDERIEN,8,ALPBX)) Q:'ALPBX D
...S ALPBY=RESULTS(ORDERIEN,3,0)+1
...S RESULTS(ORDERIEN,3,ALPBY)=$P(^ALPB(53.7,IEN,2,ORDERIEN,8,ALPBX,0),"^",2)_" (Additive)"
...S RESULTS(ORDERIEN,3,0)=ALPBY
.I +$O(^ALPB(53.7,IEN,2,ORDERIEN,9,0)) D
..S ALPBX=0
..F S ALPBX=$O(^ALPB(53.7,IEN,2,ORDERIEN,9,ALPBX)) Q:'ALPBX D
...S ALPBY=RESULTS(ORDERIEN,3,0)+1
...S RESULTS(ORDERIEN,3,ALPBY)=$P(^ALPB(53.7,IEN,2,ORDERIEN,9,ALPBX,0),"^",2)_" (Solution)"
...S RESULTS(ORDERIEN,3,0)=ALPBY
Q
;
DELPT(IEN) ; delete a patient's entire record...
; IEN = patient's record number in file 53.7
N DA,DIK,X,Y
S DA=IEN,DIK="^ALPB(53.7,"
D ^DIK
; after deleting the patient, check for any error log
; entries and delete them...
D CLEAN^ALPBUTL1(IEN)
Q
;
DELORD(IEN,OIEN) ; delete an order from a patient's record...
; IEN = patient's record number in file 53.7
; OIEN = order number's record number
N DA,DIK,X,Y
S DA=OIEN,DA(1)=IEN,DIK="^ALPB(53.7,"_DA(1)_",2,"
D ^DIK
Q
;
STATUS ; return last update date/time and count of any errors...
N ALPBCNT,ALPBPARM
S ALPBPARM=+$O(^ALPB(53.71,0))
I ALPBPARM=0 W !,"NOTICE! There is no entry in the BCMA BACKUP PARAMETERS FILE!" Q
W !,"BCMA Backup System was last updated: ",$S($P($G(^ALPB(53.71,ALPBPARM,2)),"^")'="":$$FMTE^XLFDT($P(^ALPB(53.71,ALPBPARM,2),"^")),1:"UNKNOWN")
S ALPBCNT=$$ERRCT^ALPBUTL2()
I ALPBCNT>0 W !,"NOTICE! ",ALPBCNT_" filing error"_$S(ALPBCNT=1:" has",1:"s have")_" been logged."
Q
;
CLINLIST(DTYPE) ; list of Clinics on file...
; DTYPE = 'C' for vertical (columnar) list
; 'L' for horizontal list
I $G(DTYPE)="" S DTYPE="L"
N ALPBCLIN,ALPTOTCL
W !,"Clinics with BCMA Backup Data on this workstation:",!
S ALPBCLIN=""
F S ALPBCLIN=$O(^ALPB(53.7,"AC",ALPBCLIN)) Q:ALPBCLIN="" D
.I DTYPE="L" D Q
..I $X+$L(ALPBCLIN)>IOM W !
..W ALPBCLIN S ALPTOTCL=$G(ALPTOTCL)+1
..I $O(^ALPB(53.7,"AC",ALPBCLIN))'="" W ", "
.W !?5,ALPBCLIN
I '$D(^ALPB(53.7,"AC")) W !,"No Clinics on file",!
Q
;
CLINSEL(CLIN,RESULTS) ; find a selected Clinic...
; CLIN = a string representing a clinic input by the user
; RESULTS = an array passed by reference in which possible matches
; are stored
; returns possible matches for the CLIN in RESULTS
N ALPBCLIN,ALPBX
S RESULTS(0)=0
S ALPBCLIN=""
F S ALPBCLIN=$O(^ALPB(53.7,"AC",ALPBCLIN)) Q:ALPBCLIN="" D
.I ALPBCLIN=CLIN D Q
..S RESULTS(0)=RESULTS(0)+1,RESULTS(RESULTS(0))=ALPBCLIN
.I $E(ALPBCLIN,1,$L(CLIN))=CLIN D
..S RESULTS(0)=RESULTS(0)+1,RESULTS(RESULTS(0))=ALPBCLIN
; if a straight lookup failed, let's try making any alphas
; entered by the user uppercase and try it once more...
I RESULTS(0)=0 D
.S CLIN=$$UP^XLFSTR(CLIN)
.S ALPBCLIN=""
.F S ALPBCLIN=$O(^ALPB(53.7,"AC",ALPBCLIN)) Q:ALPBCLIN="" D
..I ALPBCLIN=CLIN D Q
...S RESULTS(0)=RESULTS(0)+1,RESULTS(RESULTS(0))=ALPBCLIN
..I $E(ALPBCLIN,1,$L(CLIN))=CLIN D
...S RESULTS(0)=RESULTS(0)+1,RESULTS(RESULTS(0))=ALPBCLIN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HALPBUTL 12083 printed Oct 16, 2024@17:40:29 Page 2
ALPBUTL ;OIFO-DALLAS MW,SED,KC-BCMA BCBU REPORT FUNCTIONS AND UTILITIES ;2/28/13 8:13am
+1 ;;3.0;BAR CODE MED ADMIN;**8,73**;Mar 2004;Build 31
+2 ;
+3 ;*73 add logic to handle Clinic Orders (CO)
+4 ;
DEFPRT() ; fetch and return default printer...
+1 ; returns default printer entry from Device file based on entry in
+2 ; DEFAULT MAR PRINTER field in BCMA BACKUP PARAMETERS file (53.71)
+3 NEW X
+4 SET X=+$ORDER(^ALPB(53.71,0))
+5 IF X=0
QUIT ""
+6 QUIT $PIECE($GET(^%ZIS(1,+$PIECE(^ALPB(53.71,X,0),"^",3),0)),U)
+7 ;
DEFDAYS() ; fetch and return default days for MAR printing...
+1 ; returns default number of days to print MARs based on entry in
+2 ; DEFAULT DAYS FOR MAR field in BCMA BACKUP PARAMETERS file (53.71)
+3 ; if null or undefined, returns default of 3 (days)
+4 NEW X
+5 SET X=+$ORDER(^ALPB(53.71,0))
+6 IF X=0
QUIT 7
+7 QUIT +$PIECE(^ALPB(53.71,X,0),"^",2)
+8 ;
MLRANGE(IEN) ; find first and last Med Log entries' date/time...
+1 ; IEN = patient's record number in file 53.7
+2 ; returns a delimited string = first Med Log date/time^last Med Log date/time
+3 NEW FIRST,LAST
+4 SET FIRST=$ORDER(^ALPB(53.7,IEN,"AMLOG",""))
+5 IF FIRST=""
QUIT "^"
+6 SET FIRST=FIRST\1
+7 SET LAST=$ORDER(^ALPB(53.7,IEN,"AMLOG",""),-1)
+8 IF LAST'=""
SET LAST=LAST\1
+9 IF FIRST=LAST
QUIT FIRST_"^"
+10 QUIT FIRST_"^"_LAST
+11 ;
PAD(STRING,SPACES) ; pad a string...
+1 ; STRING = a string passed by reference
+2 ; SPACES = number of spaces to concatenate onto STRING
+3 ; returns STRING padded with SPACES number of blank spaces
+4 NEW I,RESULT
+5 IF $GET(STRING)=""
SET STRING=" "
+6 IF $GET(SPACES)=""
QUIT STRING
+7 SET RESULT=STRING
FOR I=$LENGTH(RESULT):1:SPACES
SET RESULT=RESULT_" "
+8 QUIT RESULT
+9 ;
FDAYS(START,DAYS,SPACE) ; format a sequence of DAYS beginning with START separated by SPACE...
+1 ; START = a date in FileMan internal format from which the formatted string will start
+2 ; DAYS = the number of consecutive days to return in the formatted string
+3 ; SPACE = the number of spaces between each number in the formatted string
+4 ; (if not passed, defaults to 4 spaces)
+5 ; returns a formatted string (example: 1 2 3)
+6 NEW DIM,I,J,RESULT,TODAY
+7 IF $GET(START)=""!($GET(DAYS)="")
QUIT ""
+8 IF $GET(SPACE)=""
SET SPACE=4
+9 SET (RESULT,TODAY)=+$EXTRACT(START,6,7)
+10 FOR I=1:1:SPACE
SET RESULT=RESULT_" "
+11 SET DIM=$$DIM(START)
+12 FOR I=DAYS-1:-1:1
Begin DoDot:1
+13 SET TODAY=TODAY+1
+14 IF TODAY>DIM
SET TODAY=1
+15 SET RESULT=RESULT_$SELECT(TODAY<10:"0"_TODAY,1:TODAY)
+16 IF I>1
Begin DoDot:2
+17 FOR J=1:1:SPACE
SET RESULT=RESULT_" "
End DoDot:2
End DoDot:1
+18 QUIT RESULT
+19 ;
FMONS(START,DAYS,SPACE) ; format a sequence of months given a START date separated by SPACE...
+1 ; START = a date in FileMan internal format the month of which will be the string starting point
+2 ; DAYS = the number of days that will be displayed
+3 ; SPACE = the number of spaces between each month (defaults to 1 space)
+4 ; returns a string equal to the month or months depending upon the number of days passed
+5 ; for example: if START=3021031 (Oct 31, 2002) and DAYS=3 then two month names will be
+6 ; returned: OCT NOV
+7 NEW DIM,I,J,MON,MON1,NEXTMON,RESULT,TODAY,XSPACE
+8 IF $GET(START)=""!($GET(DAYS)="")
QUIT ""
+9 IF $GET(SPACE)=""
SET SPACE=4
+10 SET (XSPACE,XSTRIP)=""
+11 FOR I=1:1:SPACE+1
SET XSPACE=XSPACE_"*"
SET XSTRIP=XSTRIP_" "
+12 SET DIM=$$DIM(START)
SET TODAY=+$EXTRACT(START,6,7)
SET MON1=+$EXTRACT(START,4,5)
+13 SET (RESULT,MON)=$$MONN(MON1)
+14 IF (TODAY+DAYS)<DIM!(TODAY+DAYS=DIM)
QUIT RESULT
+15 FOR I=1:1:DAYS
Begin DoDot:1
+16 SET RESULT=RESULT_XSPACE
+17 SET TODAY=TODAY+1
+18 IF TODAY<DIM!(TODAY=DIM)
QUIT
+19 SET MON1=MON1+1
+20 IF MON1>12
SET MON1=1
+21 SET MON=$$MONN(MON1)
SET RESULT=RESULT_MON
+22 SET DIM=$$DIM($EXTRACT(START,1,3)_$SELECT(MON1<10:"0"_MON1,1:MON1))
SET TODAY=0
End DoDot:1
+23 FOR I=$LENGTH(RESULT):-1
if $EXTRACT(RESULT,I)'="*"!(I=0)
QUIT
+24 SET RESULT=$EXTRACT(RESULT,1,I)
SET RESULT=$TRANSLATE(RESULT,XSPACE,XSTRIP)
+25 QUIT RESULT
+26 ;
FDATES(START,DAYS,RESULTS) ;
+1 NEW I,X,X1,X2
+2 SET RESULTS(0)=" "_$EXTRACT(START,4,5)_"/"_$EXTRACT(START,6,7)_" "
SET RESULTS(1)=START
+3 FOR I=1:1:DAYS-1
Begin DoDot:1
+4 SET X1=START
SET X2=I
+5 DO C^%DTC
+6 SET RESULTS(I+1)=X
SET RESULTS(0)=RESULTS(0)_" "_$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_" "
+7 KILL X,X1,X2
End DoDot:1
+8 QUIT
+9 ;
DIM(X) ; number of days in a specified month...
+1 ; X = a date in internal FileMan format (can be partial: YYYMM)
+2 ; returns a number representing the number of days in month X
+3 IF $GET(X)=""
QUIT 0
+4 NEW DAYS,MON,YEAR
+5 SET MON=+$EXTRACT(X,4,5)
+6 IF MON<1
QUIT 0
+7 SET DAYS=$SELECT(MON=1:31,MON=2:28,MON=3:31,MON=4:30,MON=5:31,MON=6:30,MON=7:31,MON=8:31,MON=9:30,MON=10:31,MON=11:30,MON=12:31,1:0)
+8 ; if passed date is in Feb, check for leap year and adjust days if needed...
+9 IF MON=2
Begin DoDot:1
+10 SET YEAR=+$EXTRACT(X,1,3)+1700
+11 IF $$LEAP^XLFDT2(YEAR)
SET DAYS=29
End DoDot:1
+12 QUIT DAYS
+13 ;
MONN(X) ; month name...
+1 ; X = month number (1-12)
+2 ; returns name of month specified in X
+3 IF $GET(X)=""
QUIT ""
+4 SET X=+X
+5 QUIT $SELECT(X=1:"JAN",X=2:"FEB",X=3:"MAR",X=4:"APR",X=5:"MAY",X=6:"JUN",X=7:"JUL",X=8:"AUG",X=9:"SEP",X=10:"OCT",X=11:"NOV",X=12:"DEC",1:"")
+6 ;
FDATE(X) ; special format for a FileMan date/time...
+1 ; X = date and time (time is optional) in FileMan format
+2 ; returns the FileMan date/time in the format MM/DD/YY@HH:MM
+3 NEW DATE,FMDATE
+4 SET DATE=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)
+5 SET FMDATE=$$FMTE^XLFDT(X)
+6 IF $PIECE(FMDATE,"@",2)'=""
SET DATE=DATE_"@"_$PIECE($PIECE(FMDATE,"@",2),":")_":"_$PIECE($PIECE(FMDATE,"@",2),":",2)
+7 QUIT DATE
+8 ;
WARDLIST(DTYPE) ; list of wards on file...
+1 ; DTYPE = 'C' for vertical (columnar) list
+2 ; 'L' for horizontal list
+3 IF $GET(DTYPE)=""
SET DTYPE="L"
+4 NEW ALPBWARD
+5 WRITE !,"Wards with BCMA Backup Data on this workstation:",!
+6 SET ALPBWARD=""
+7 FOR
SET ALPBWARD=$ORDER(^ALPB(53.7,"AW",ALPBWARD))
if ALPBWARD=""
QUIT
Begin DoDot:1
+8 IF DTYPE="L"
Begin DoDot:2
+9 IF $X+$LENGTH(ALPBWARD)>IOM
WRITE !
+10 WRITE ALPBWARD
+11 IF $ORDER(^ALPB(53.7,"AW",ALPBWARD))'=""
WRITE ", "
End DoDot:2
QUIT
+12 WRITE !?5,ALPBWARD
End DoDot:1
+13 QUIT
+14 ;
WARDSEL(WARD,RESULTS) ; find a selected ward...
+1 ; WARD = a string representing a ward input by the user
+2 ; RESULTS = an array passed by reference in which possible matches are stored
+3 ; returns possible matches for the WARD in RESULTS
+4 NEW ALPBWARD,ALPBX
+5 SET RESULTS(0)=0
+6 SET ALPBWARD=""
+7 FOR
SET ALPBWARD=$ORDER(^ALPB(53.7,"AW",ALPBWARD))
if ALPBWARD=""
QUIT
Begin DoDot:1
+8 IF ALPBWARD=WARD
Begin DoDot:2
+9 SET RESULTS(0)=RESULTS(0)+1
SET RESULTS(RESULTS(0))=ALPBWARD
End DoDot:2
QUIT
+10 IF ALPBWARD[WARD
Begin DoDot:2
+11 SET RESULTS(0)=RESULTS(0)+1
SET RESULTS(RESULTS(0))=ALPBWARD
End DoDot:2
End DoDot:1
+12 ; if a straight lookup failed, let's try making any alphas
+13 ; entered by the user uppercase and try it once more...
+14 IF RESULTS(0)=0
Begin DoDot:1
+15 SET WARD=$$UP^XLFSTR(WARD)
+16 SET ALPBWARD=""
+17 FOR
SET ALPBWARD=$ORDER(^ALPB(53.7,"AW",ALPBWARD))
if ALPBWARD=""
QUIT
Begin DoDot:2
+18 IF ALPBWARD=WARD
Begin DoDot:3
+19 SET RESULTS(0)=RESULTS(0)+1
SET RESULTS(RESULTS(0))=ALPBWARD
End DoDot:3
QUIT
+20 IF ALPBWARD[WARD
Begin DoDot:3
+21 SET RESULTS(0)=RESULTS(0)+1
SET RESULTS(RESULTS(0))=ALPBWARD
End DoDot:3
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
OTYP(CODE) ; expand order type for printing...
+1 ; CODE = a character representing an order type
+2 ; returns expanded order type from ^DD(53.79,6,0)
+3 IF $GET(CODE)=""
QUIT ""
+4 QUIT $SELECT(CODE="U":"UNIT DOSE",CODE="V":"IV",CODE="P":"PENDING",1:CODE)
+5 ;
ORDS(IEN,DATE,RESULTS,CO,INCLIM) ; retrieve orders for a given patient... *73
+1 ; IEN = patient's record number in file 53.7
+2 ; DATE = the date/time used to determine whether all or only current
+3 ; orders are returned:
+4 ; >passed as a date/time in FileMan internal format -- only orders
+5 ; with a stop date/time equal to or greater than DATE are returned
+6 ; >passed = "" then all orders are returned regardless of status
+7 ; returns RESULTS(order# ien) -- note: RESULTS(0)=count of active orders
+8 ; *73 add 2 new input varaibles below
+9 ; CO = Clinic name selected to match for return orders, if clinic
+10 ; report requested.
+11 ; INCLIM = Include IM orders for a CO report request. Y or N
+12 ;
+13 ;optional parameters
SET CO=$GET(CO)
SET INCLIM=$GET(INCLIM)
+14 IF +$GET(IEN)=0
SET RESULTS(0)=0
QUIT
+15 NEW ALPBX,ALPBY,ORDERDAT,ORIEN,ORDERST,CLNAM
+16 SET (ORDERIEN,RESULTS(0))=0
+17 FOR
SET ORDERIEN=$ORDER(^ALPB(53.7,IEN,2,ORDERIEN))
if 'ORDERIEN
QUIT
Begin DoDot:1
+18 SET ORDERDAT(0)=$GET(^ALPB(53.7,IEN,2,ORDERIEN,0))
+19 SET ORDERDAT(1)=$GET(^ALPB(53.7,IEN,2,ORDERIEN,1))
+20 SET ORDERDAT(3)=$GET(^ALPB(53.7,IEN,2,ORDERIEN,3))
+21 SET ORDERDAT(4)=$GET(^ALPB(53.7,IEN,2,ORDERIEN,4))
+22 SET ORDERST=$PIECE($PIECE(ORDERDAT(0),"^",3),"~")
+23 ; *73 add CO logic below
+24 ;is a Clinic report
if CO]""
SET CLNAM=$PIECE(ORDERDAT(0),U,5)
+25 ;skip, not selected CLIN
IF CO]""
IF CLNAM]""
IF CO'=CLNAM
KILL ORDERDAT
QUIT
+26 ;skip IM recs
IF CO]""
IF CLNAM=""
IF INCLIM="N"
KILL ORDERDAT
QUIT
+27 ;
+28 ; is this order current?...
+29 IF $GET(DATE)'=""&($PIECE(ORDERDAT(1),"^",2)<$GET(DATE))
KILL ORDERDAT
QUIT
+30 ; if current, is it still active?...
+31 IF $GET(DATE)'=""&(ORDERST'="CM")&(ORDERST'="ZS")&(ORDERST'="ZU")
KILL ORDERDAT
QUIT
+32 SET RESULTS(0)=RESULTS(0)+1
+33 SET RESULTS(ORDERIEN)=$PIECE(ORDERDAT(0),"^")
+34 SET RESULTS("B",$PIECE(ORDERDAT(0),"^"))=ORDERIEN
+35 SET RESULTS(ORDERIEN,1)=$SELECT($PIECE(ORDERDAT(3),"^")="V":"IV",$PIECE(ORDERDAT(3),"^")="U":"UD",1:$PIECE(ORDERDAT(3),"^"))
+36 SET RESULTS(ORDERIEN,2)=ORDERST
+37 SET RESULTS(ORDERIEN,3,0)=0
+38 ;S RESULTS(ORDERIEN,4)=$P($G(ORDERDAT(4)),"^",3)
+39 SET RESULTS(ORDERIEN,4)=$GET(ORDERDAT(4))
+40 IF +$ORDER(^ALPB(53.7,IEN,2,ORDERIEN,7,0))
Begin DoDot:2
+41 SET ALPBX=0
+42 FOR
SET ALPBX=$ORDER(^ALPB(53.7,IEN,2,ORDERIEN,7,ALPBX))
if 'ALPBX
QUIT
Begin DoDot:3
+43 SET ALPBY=RESULTS(ORDERIEN,3,0)+1
+44 SET RESULTS(ORDERIEN,3,ALPBY)=$PIECE(^ALPB(53.7,IEN,2,ORDERIEN,7,ALPBX,0),"^",2)
+45 SET RESULTS(ORDERIEN,3,0)=ALPBY
End DoDot:3
End DoDot:2
+46 IF +$ORDER(^ALPB(53.7,IEN,2,ORDERIEN,8,0))
Begin DoDot:2
+47 SET ALPBX=0
+48 FOR
SET ALPBX=$ORDER(^ALPB(53.7,IEN,2,ORDERIEN,8,ALPBX))
if 'ALPBX
QUIT
Begin DoDot:3
+49 SET ALPBY=RESULTS(ORDERIEN,3,0)+1
+50 SET RESULTS(ORDERIEN,3,ALPBY)=$PIECE(^ALPB(53.7,IEN,2,ORDERIEN,8,ALPBX,0),"^",2)_" (Additive)"
+51 SET RESULTS(ORDERIEN,3,0)=ALPBY
End DoDot:3
End DoDot:2
+52 IF +$ORDER(^ALPB(53.7,IEN,2,ORDERIEN,9,0))
Begin DoDot:2
+53 SET ALPBX=0
+54 FOR
SET ALPBX=$ORDER(^ALPB(53.7,IEN,2,ORDERIEN,9,ALPBX))
if 'ALPBX
QUIT
Begin DoDot:3
+55 SET ALPBY=RESULTS(ORDERIEN,3,0)+1
+56 SET RESULTS(ORDERIEN,3,ALPBY)=$PIECE(^ALPB(53.7,IEN,2,ORDERIEN,9,ALPBX,0),"^",2)_" (Solution)"
+57 SET RESULTS(ORDERIEN,3,0)=ALPBY
End DoDot:3
End DoDot:2
End DoDot:1
+58 QUIT
+59 ;
DELPT(IEN) ; delete a patient's entire record...
+1 ; IEN = patient's record number in file 53.7
+2 NEW DA,DIK,X,Y
+3 SET DA=IEN
SET DIK="^ALPB(53.7,"
+4 DO ^DIK
+5 ; after deleting the patient, check for any error log
+6 ; entries and delete them...
+7 DO CLEAN^ALPBUTL1(IEN)
+8 QUIT
+9 ;
DELORD(IEN,OIEN) ; delete an order from a patient's record...
+1 ; IEN = patient's record number in file 53.7
+2 ; OIEN = order number's record number
+3 NEW DA,DIK,X,Y
+4 SET DA=OIEN
SET DA(1)=IEN
SET DIK="^ALPB(53.7,"_DA(1)_",2,"
+5 DO ^DIK
+6 QUIT
+7 ;
STATUS ; return last update date/time and count of any errors...
+1 NEW ALPBCNT,ALPBPARM
+2 SET ALPBPARM=+$ORDER(^ALPB(53.71,0))
+3 IF ALPBPARM=0
WRITE !,"NOTICE! There is no entry in the BCMA BACKUP PARAMETERS FILE!"
QUIT
+4 WRITE !,"BCMA Backup System was last updated: ",$SELECT($PIECE($GET(^ALPB(53.71,ALPBPARM,2)),"^")'="":$$FMTE^XLFDT($PIECE(^ALPB(53.71,ALPBPARM,2),"^")),1:"UNKNOWN")
+5 SET ALPBCNT=$$ERRCT^ALPBUTL2()
+6 IF ALPBCNT>0
WRITE !,"NOTICE! ",ALPBCNT_" filing error"_$SELECT(ALPBCNT=1:" has",1:"s have")_" been logged."
+7 QUIT
+8 ;
CLINLIST(DTYPE) ; list of Clinics on file...
+1 ; DTYPE = 'C' for vertical (columnar) list
+2 ; 'L' for horizontal list
+3 IF $GET(DTYPE)=""
SET DTYPE="L"
+4 NEW ALPBCLIN,ALPTOTCL
+5 WRITE !,"Clinics with BCMA Backup Data on this workstation:",!
+6 SET ALPBCLIN=""
+7 FOR
SET ALPBCLIN=$ORDER(^ALPB(53.7,"AC",ALPBCLIN))
if ALPBCLIN=""
QUIT
Begin DoDot:1
+8 IF DTYPE="L"
Begin DoDot:2
+9 IF $X+$LENGTH(ALPBCLIN)>IOM
WRITE !
+10 WRITE ALPBCLIN
SET ALPTOTCL=$GET(ALPTOTCL)+1
+11 IF $ORDER(^ALPB(53.7,"AC",ALPBCLIN))'=""
WRITE ", "
End DoDot:2
QUIT
+12 WRITE !?5,ALPBCLIN
End DoDot:1
+13 IF '$DATA(^ALPB(53.7,"AC"))
WRITE !,"No Clinics on file",!
+14 QUIT
+15 ;
CLINSEL(CLIN,RESULTS) ; find a selected Clinic...
+1 ; CLIN = a string representing a clinic input by the user
+2 ; RESULTS = an array passed by reference in which possible matches
+3 ; are stored
+4 ; returns possible matches for the CLIN in RESULTS
+5 NEW ALPBCLIN,ALPBX
+6 SET RESULTS(0)=0
+7 SET ALPBCLIN=""
+8 FOR
SET ALPBCLIN=$ORDER(^ALPB(53.7,"AC",ALPBCLIN))
if ALPBCLIN=""
QUIT
Begin DoDot:1
+9 IF ALPBCLIN=CLIN
Begin DoDot:2
+10 SET RESULTS(0)=RESULTS(0)+1
SET RESULTS(RESULTS(0))=ALPBCLIN
End DoDot:2
QUIT
+11 IF $EXTRACT(ALPBCLIN,1,$LENGTH(CLIN))=CLIN
Begin DoDot:2
+12 SET RESULTS(0)=RESULTS(0)+1
SET RESULTS(RESULTS(0))=ALPBCLIN
End DoDot:2
End DoDot:1
+13 ; if a straight lookup failed, let's try making any alphas
+14 ; entered by the user uppercase and try it once more...
+15 IF RESULTS(0)=0
Begin DoDot:1
+16 SET CLIN=$$UP^XLFSTR(CLIN)
+17 SET ALPBCLIN=""
+18 FOR
SET ALPBCLIN=$ORDER(^ALPB(53.7,"AC",ALPBCLIN))
if ALPBCLIN=""
QUIT
Begin DoDot:2
+19 IF ALPBCLIN=CLIN
Begin DoDot:3
+20 SET RESULTS(0)=RESULTS(0)+1
SET RESULTS(RESULTS(0))=ALPBCLIN
End DoDot:3
QUIT
+21 IF $EXTRACT(ALPBCLIN,1,$LENGTH(CLIN))=CLIN
Begin DoDot:3
+22 SET RESULTS(0)=RESULTS(0)+1
SET RESULTS(RESULTS(0))=ALPBCLIN
End DoDot:3
End DoDot:2
End DoDot:1
+23 QUIT
