ALPBUTL3 ;OIFO-DALLAS MW,SED,KC-BCBU BACKUP REPORT FUNCTIONS AND UTILITIES ;01/01/03
;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
START(DAY) ;Get current date
D NOW^%DTC
S Y=X
S STARD=%I(2)
D DD^%DT
S MON=$E(Y,1,3)
S LD=$S(MON="JAN":31,MON="FEB":29,MON="MAR":31,MON="APR":30,MON="MAY":31,MON="JUN":30,MON="JUL":31,MON="AUG":31,MON="SEP":30,MON="OCT":31,MON="NOV":30,MON="DEC":31)
S LDD=LD+1
S SP=69,CNT=0
S SS=STARD+DAY
I SS>LDD S SS=LDD
I SS<LDD S LDD=SS
F J=STARD:0 DO Q:J=LDD
.S SP=SP+6,CNT=CNT+1
.W ?SP,J
.S J=J+1
.I J=SS Q
I CNT'=DAY F J=1:1 DO Q:CNT=DAY
.S SP=SP+6,CNT=CNT+1
.W ?SP,J
Q
MON(DAY) ;Get the month
D NOW^%DTC
S Y=X
S STARD=%I(2)
D DD^%DT
S MON=$E(Y,1,3)
S LD=$S(MON="JAN":31,MON="FEB":29,MON="MAR":31,MON="APR":30,MON="MAY":31,MON="JUN":30,MON="JUL":31,MON="AUG":31,MON="SEP":30,MON="OCT":31,MON="NOV":30,MON="DEC":31)
Q
ARRAY(DAY) ;BUILD ARRAY FOR TO FIND NEXT MONTH
S MONT("JAN")="FEB"
S MONT("FEB")="MAR"
S MONT("MAR")="APR"
S MONT("APR")="MAY"
S MONT("MAY")="JUN"
S MONT("JUN")="JUL"
S MONT("JUL")="AUG"
S MONT("AUG")="SEP"
S MONT("SEP")="OCT"
S MONT("OCT")="NO"
S MONT("NOV")="DEC"
S MONT("DEC")="JAN"
D NOW^%DTC
S Y=X
S STARD=%I(2)
D DD^%DT
S MON=$E(Y,1,3)
S LD=$S(MON="JAN":31,MON="FEB":29,MON="MAR":31,MON="APR":30,MON="MAY":31,MON="JUN":30,MON="JUL":31,MON="AUG":31,MON="SEP":30,MON="OCT":31,MON="NOV":30,MON="DEC":31)
S LDD=LD+1
S SP=69,CNT=0
S SS=STARD+DAY
I SS>LDD S SS=LDD
I SS<LDD S LDD=SS
F J=STARD:0 DO Q:J=LDD
.S SP=SP+6,CNT=CNT+1
.S J=J+1
.I J=SS Q
I CNT'=DAY W ?SP+6,$P(MONT(MON),"^",1)
Q
DEFML() ; fetch and return default med log print...
; returns default number of med log entries to print based on entry in
; MED-LOG NUMBER field in BCMA BACKUP PARAMETERS file (53.71)
N X
S X=$S(+$P($G(^ALPB(53.71,1,2)),U,4)>0:+$P(^ALPB(53.71,1,2),U,4),1:1)
Q X
DEFOR() ; fetch and return purge order flag...
; returns the number of day to hold a patient order after
; the Stop Date. Default is 7
; Based on entry in PURGE ORDER DAYS field in BCMA BACKUP
; PARAMETERS file (53.71)
N X
S X=$S(+$P($G(^ALPB(53.71,1,2)),U,2)>0:+$P(^ALPB(53.71,1,2),U,2),1:7)
Q X
DEFPR() ; fetch and return purge patient flag...
; returns the number of days to hold the patient record
; with no orders. Default is 30
; Based on entry in PURGE PATIENT field in BCMA BACKUP
; PARAMETERS file (53.71)
N X
S X=$S(+$P($G(^ALPB(53.71,1,2)),U,3)>0:+$P(^ALPB(53.71,1,2),U,3),1:30)
Q X
LSTACT ; Build a cross reference by patient by drug to keep up
; with the last action of the drug. The x-ref is built but stays
; even if order is purged. The x-ref gets removed when the patient
; is purged.
; ^ALPB(53.1,DFN,"LSTACT",DRUG,ACTION DATE)=PERSON^ACTION
N ALP,DRUG,DATE
;Q:+$G(DA(2))'>0!(+$G(DA(1))'>0)!(+$G(DA)'>0)
; get drug info - can be multiple
S ALP=0 F ALP=$O(^ALPB(53.7,DA(2),2,DA(1),7,ALP)) Q:+ALP'>0 D
. S DRUG=$P($G(^ALPB(53.7,DA(2),2,DA(1),7,ALP,0)),U,1)
. Q:+DRUG'>0
. S DATE=$P($G(^ALPB(53.7,DA(2),2,DA(1),10,DA,0)),U,1)
. S ^ALPB(53.7,DA(2),"LSTACT",DRUG,(9999999-DATE))=$G(^ALPB(53.7,DA(2),2,DA(1),10,DA,0))
Q
LACT(ALPDFN,ALPDRUG) ; Retrieve the last action infor for a patient
; for a certian drug
; ALPDFN = Patient DFN
; ALPDRUG = Drug Ordable Item IEN
N DATA,ALP
Q:+$G(ALPDFN)'>0 ""
Q:+$G(ALPDRUG)'>0 ""
I '$D(^ALPB(53.7,ALPDFN,"LSTACT",ALPDRUG)) Q ""
S ALP=$O(^ALPB(53.7,ALPDFN,"LSTACT",ALPDRUG,0))
S DATA=$G(^ALPB(53.7,ALPDFN,"LSTACT",ALPDRUG,ALP))
Q DATA
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HALPBUTL3 3585 printed Oct 16, 2024@17:40:32 Page 2
ALPBUTL3 ;OIFO-DALLAS MW,SED,KC-BCBU BACKUP REPORT FUNCTIONS AND UTILITIES ;01/01/03
+1 ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
START(DAY) ;Get current date
+1 DO NOW^%DTC
+2 SET Y=X
+3 SET STARD=%I(2)
+4 DO DD^%DT
+5 SET MON=$EXTRACT(Y,1,3)
+6 SET LD=$SELECT(MON="JAN":31,MON="FEB":29,MON="MAR":31,MON="APR":30,MON="MAY":31,MON="JUN":30,MON="JUL":31,MON="AUG":31,MON="SEP":30,MON="OCT":31,MON="NOV":30,MON="DEC":31)
+7 SET LDD=LD+1
+8 SET SP=69
SET CNT=0
+9 SET SS=STARD+DAY
+10 IF SS>LDD
SET SS=LDD
+11 IF SS<LDD
SET LDD=SS
+12 FOR J=STARD:0
Begin DoDot:1
+13 SET SP=SP+6
SET CNT=CNT+1
+14 WRITE ?SP,J
+15 SET J=J+1
+16 IF J=SS
QUIT
End DoDot:1
if J=LDD
QUIT
+17 IF CNT'=DAY
FOR J=1:1
Begin DoDot:1
+18 SET SP=SP+6
SET CNT=CNT+1
+19 WRITE ?SP,J
End DoDot:1
if CNT=DAY
QUIT
+20 QUIT
MON(DAY) ;Get the month
+1 DO NOW^%DTC
+2 SET Y=X
+3 SET STARD=%I(2)
+4 DO DD^%DT
+5 SET MON=$EXTRACT(Y,1,3)
+6 SET LD=$SELECT(MON="JAN":31,MON="FEB":29,MON="MAR":31,MON="APR":30,MON="MAY":31,MON="JUN":30,MON="JUL":31,MON="AUG":31,MON="SEP":30,MON="OCT":31,MON="NOV":30,MON="DEC":31)
+7 QUIT
ARRAY(DAY) ;BUILD ARRAY FOR TO FIND NEXT MONTH
+1 SET MONT("JAN")="FEB"
+2 SET MONT("FEB")="MAR"
+3 SET MONT("MAR")="APR"
+4 SET MONT("APR")="MAY"
+5 SET MONT("MAY")="JUN"
+6 SET MONT("JUN")="JUL"
+7 SET MONT("JUL")="AUG"
+8 SET MONT("AUG")="SEP"
+9 SET MONT("SEP")="OCT"
+10 SET MONT("OCT")="NO"
+11 SET MONT("NOV")="DEC"
+12 SET MONT("DEC")="JAN"
+13 DO NOW^%DTC
+14 SET Y=X
+15 SET STARD=%I(2)
+16 DO DD^%DT
+17 SET MON=$EXTRACT(Y,1,3)
+18 SET LD=$SELECT(MON="JAN":31,MON="FEB":29,MON="MAR":31,MON="APR":30,MON="MAY":31,MON="JUN":30,MON="JUL":31,MON="AUG":31,MON="SEP":30,MON="OCT":31,MON="NOV":30,MON="DEC":31)
+19 SET LDD=LD+1
+20 SET SP=69
SET CNT=0
+21 SET SS=STARD+DAY
+22 IF SS>LDD
SET SS=LDD
+23 IF SS<LDD
SET LDD=SS
+24 FOR J=STARD:0
Begin DoDot:1
+25 SET SP=SP+6
SET CNT=CNT+1
+26 SET J=J+1
+27 IF J=SS
QUIT
End DoDot:1
if J=LDD
QUIT
+28 IF CNT'=DAY
WRITE ?SP+6,$PIECE(MONT(MON),"^",1)
+29 QUIT
DEFML() ; fetch and return default med log print...
+1 ; returns default number of med log entries to print based on entry in
+2 ; MED-LOG NUMBER field in BCMA BACKUP PARAMETERS file (53.71)
+3 NEW X
+4 SET X=$SELECT(+$PIECE($GET(^ALPB(53.71,1,2)),U,4)>0:+$PIECE(^ALPB(53.71,1,2),U,4),1:1)
+5 QUIT X
DEFOR() ; fetch and return purge order flag...
+1 ; returns the number of day to hold a patient order after
+2 ; the Stop Date. Default is 7
+3 ; Based on entry in PURGE ORDER DAYS field in BCMA BACKUP
+4 ; PARAMETERS file (53.71)
+5 NEW X
+6 SET X=$SELECT(+$PIECE($GET(^ALPB(53.71,1,2)),U,2)>0:+$PIECE(^ALPB(53.71,1,2),U,2),1:7)
+7 QUIT X
DEFPR() ; fetch and return purge patient flag...
+1 ; returns the number of days to hold the patient record
+2 ; with no orders. Default is 30
+3 ; Based on entry in PURGE PATIENT field in BCMA BACKUP
+4 ; PARAMETERS file (53.71)
+5 NEW X
+6 SET X=$SELECT(+$PIECE($GET(^ALPB(53.71,1,2)),U,3)>0:+$PIECE(^ALPB(53.71,1,2),U,3),1:30)
+7 QUIT X
LSTACT ; Build a cross reference by patient by drug to keep up
+1 ; with the last action of the drug. The x-ref is built but stays
+2 ; even if order is purged. The x-ref gets removed when the patient
+3 ; is purged.
+4 ; ^ALPB(53.1,DFN,"LSTACT",DRUG,ACTION DATE)=PERSON^ACTION
+5 NEW ALP,DRUG,DATE
+6 ;Q:+$G(DA(2))'>0!(+$G(DA(1))'>0)!(+$G(DA)'>0)
+7 ; get drug info - can be multiple
+8 SET ALP=0
FOR ALP=$ORDER(^ALPB(53.7,DA(2),2,DA(1),7,ALP))
if +ALP'>0
QUIT
Begin DoDot:1
+9 SET DRUG=$PIECE($GET(^ALPB(53.7,DA(2),2,DA(1),7,ALP,0)),U,1)
+10 if +DRUG'>0
QUIT
+11 SET DATE=$PIECE($GET(^ALPB(53.7,DA(2),2,DA(1),10,DA,0)),U,1)
+12 SET ^ALPB(53.7,DA(2),"LSTACT",DRUG,(9999999-DATE))=$GET(^ALPB(53.7,DA(2),2,DA(1),10,DA,0))
End DoDot:1
+13 QUIT
LACT(ALPDFN,ALPDRUG) ; Retrieve the last action infor for a patient
+1 ; for a certian drug
+2 ; ALPDFN = Patient DFN
+3 ; ALPDRUG = Drug Ordable Item IEN
+4 NEW DATA,ALP
+5 if +$GET(ALPDFN)'>0
QUIT ""
+6 if +$GET(ALPDRUG)'>0
QUIT ""
+7 IF '$DATA(^ALPB(53.7,ALPDFN,"LSTACT",ALPDRUG))
QUIT ""
+8 SET ALP=$ORDER(^ALPB(53.7,ALPDFN,"LSTACT",ALPDRUG,0))
+9 SET DATA=$GET(^ALPB(53.7,ALPDFN,"LSTACT",ALPDRUG,ALP))
+10 QUIT DATA
