ALPBUTL3.m

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

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