source: WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBUTL3.m@ 1608

Last change on this file since 1608 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 3.4 KB
RevLine 
[613]1ALPBUTL3 ;OIFO-DALLAS MW,SED,KC-BCBU BACKUP REPORT FUNCTIONS AND UTILITIES ;01/01/03
2 ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
3START(DAY) ;Get current date
4 D NOW^%DTC
5 S Y=X
6 S STARD=%I(2)
7 D DD^%DT
8 S MON=$E(Y,1,3)
9 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)
10 S LDD=LD+1
11 S SP=69,CNT=0
12 S SS=STARD+DAY
13 I SS>LDD S SS=LDD
14 I SS<LDD S LDD=SS
15 F J=STARD:0 DO Q:J=LDD
16 .S SP=SP+6,CNT=CNT+1
17 .W ?SP,J
18 .S J=J+1
19 .I J=SS Q
20 I CNT'=DAY F J=1:1 DO Q:CNT=DAY
21 .S SP=SP+6,CNT=CNT+1
22 .W ?SP,J
23 Q
24MON(DAY) ;Get the month
25 D NOW^%DTC
26 S Y=X
27 S STARD=%I(2)
28 D DD^%DT
29 S MON=$E(Y,1,3)
30 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)
31 Q
32ARRAY(DAY) ;BUILD ARRAY FOR TO FIND NEXT MONTH
33 S MONT("JAN")="FEB"
34 S MONT("FEB")="MAR"
35 S MONT("MAR")="APR"
36 S MONT("APR")="MAY"
37 S MONT("MAY")="JUN"
38 S MONT("JUN")="JUL"
39 S MONT("JUL")="AUG"
40 S MONT("AUG")="SEP"
41 S MONT("SEP")="OCT"
42 S MONT("OCT")="NO"
43 S MONT("NOV")="DEC"
44 S MONT("DEC")="JAN"
45 D NOW^%DTC
46 S Y=X
47 S STARD=%I(2)
48 D DD^%DT
49 S MON=$E(Y,1,3)
50 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)
51 S LDD=LD+1
52 S SP=69,CNT=0
53 S SS=STARD+DAY
54 I SS>LDD S SS=LDD
55 I SS<LDD S LDD=SS
56 F J=STARD:0 DO Q:J=LDD
57 .S SP=SP+6,CNT=CNT+1
58 .S J=J+1
59 .I J=SS Q
60 I CNT'=DAY W ?SP+6,$P(MONT(MON),"^",1)
61 Q
62DEFML() ; fetch and return default med log print...
63 ; returns default number of med log entries to print based on entry in
64 ; MED-LOG NUMBER field in BCMA BACKUP PARAMETERS file (53.71)
65 N X
66 S X=$S(+$P($G(^ALPB(53.71,1,2)),U,4)>0:+$P(^ALPB(53.71,1,2),U,4),1:1)
67 Q X
68DEFOR() ; fetch and return purge order flag...
69 ; returns the number of day to hold a patient order after
70 ; the Stop Date. Default is 7
71 ; Based on entry in PURGE ORDER DAYS field in BCMA BACKUP
72 ; PARAMETERS file (53.71)
73 N X
74 S X=$S(+$P($G(^ALPB(53.71,1,2)),U,2)>0:+$P(^ALPB(53.71,1,2),U,2),1:7)
75 Q X
76DEFPR() ; fetch and return purge patient flag...
77 ; returns the number of days to hold the patient record
78 ; with no orders. Default is 30
79 ; Based on entry in PURGE PATIENT field in BCMA BACKUP
80 ; PARAMETERS file (53.71)
81 N X
82 S X=$S(+$P($G(^ALPB(53.71,1,2)),U,3)>0:+$P(^ALPB(53.71,1,2),U,3),1:30)
83 Q X
84LSTACT ; Build a cross reference by patient by drug to keep up
85 ; with the last action of the drug. The x-ref is built but stays
86 ; even if order is purged. The x-ref gets removed when the patient
87 ; is purged.
88 ; ^ALPB(53.1,DFN,"LSTACT",DRUG,ACTION DATE)=PERSON^ACTION
89 N ALP,DRUG,DATE
90 ;Q:+$G(DA(2))'>0!(+$G(DA(1))'>0)!(+$G(DA)'>0)
91 ; get drug info - can be multiple
92 S ALP=0 F ALP=$O(^ALPB(53.7,DA(2),2,DA(1),7,ALP)) Q:+ALP'>0 D
93 . S DRUG=$P($G(^ALPB(53.7,DA(2),2,DA(1),7,ALP,0)),U,1)
94 . Q:+DRUG'>0
95 . S DATE=$P($G(^ALPB(53.7,DA(2),2,DA(1),10,DA,0)),U,1)
96 . S ^ALPB(53.7,DA(2),"LSTACT",DRUG,(9999999-DATE))=$G(^ALPB(53.7,DA(2),2,DA(1),10,DA,0))
97 Q
98LACT(ALPDFN,ALPDRUG) ; Retrieve the last action infor for a patient
99 ; for a certian drug
100 ; ALPDFN = Patient DFN
101 ; ALPDRUG = Drug Ordable Item IEN
102 N DATA,ALP
103 Q:+$G(ALPDFN)'>0 ""
104 Q:+$G(ALPDRUG)'>0 ""
105 I '$D(^ALPB(53.7,ALPDFN,"LSTACT",ALPDRUG)) Q ""
106 S ALP=$O(^ALPB(53.7,ALPDFN,"LSTACT",ALPDRUG,0))
107 S DATA=$G(^ALPB(53.7,ALPDFN,"LSTACT",ALPDRUG,ALP))
108 Q DATA
Note: See TracBrowser for help on using the repository browser.