PSBPRND.m

PSBPRND ;BIRMINGHAM/EFC-BCMA PRN DOCUMENTING ;May 2002

 ;;2.0;BAR CODE MED ADMIN;**32**;May 2002

 ;

 ;Queue the routine

ENV(PSBPRNDT,PSBSTRT,PSBDUZ,PRNMSG) ;

 I $G(DUZ)="" W !,"Your DUZ is not defined. It must be defined." Q

 K ZTSAVE,ZTSK S ZTRTN="PROCESS^PSBPRND(PSBPRNDT,PSBSTRTE,PSBDUZ,PSBPRNM)",ZTDESC="BCMA PRN DOCUMENTATION",ZTIO=""

 W !!

 S ZTSAVE("PSBPRNDT")=""

 S ZTSAVE("PSBSTRTE")=""

 S ZTSAVE("PSBDUZ")=""

 S ZTSAVE("PSBPRNM")=""

 D ^%ZTLOAD

 I $D(ZTSK) D

 .W !!,"The PRN effectiveness documenting process was ",$S($G(ZTSK):"",1:"NOT"),"queued",!

 .W !," TASK#: "_$G(ZTSK)

 Q

PSBPRNS ;Document all administrations of a PRN order that have NOT had

 ; the PRN Effectiveness documented for dates user provided

 ;

 N PSBIEN

 I $G(DUZ)="" W !,"Your DUZ is not defined. It must be defined." Q

 S PSBDUZ=$G(DUZ)

 D HEADER

 ;get start date

 S %DT="AEQ",%DT("A")="Select Date to Process From: "

 S %DT("B")=""

 W ! D ^%DT Q:+Y<1  S PSBDT=Y

 S PSBPRNDT=PSBDT D D^DIQ

 ;Get stop date

 S %DT="AEQ",%DT("A")="Select Date to Process Up to: "

 S %DT("B")=""

 W ! D ^%DT Q:+Y<1  S PSBDTA=Y

 S PSBSTRTE=PSBDTA D D^DIQ

 I PSBPRNDT>PSBSTRTE W !,"Start date cannot be greater than end date"  Q

 ;Write user running routine

 S PSBNAME=$P(^VA(200,PSBDUZ,0),"^",1)

 W !!,"PRN effectiveness entered by: ",PSBNAME,!

 D HEADER

 ;COMMIT OR QUIT

 S Y=PSBDTA D DD^%DT S PSBRDT=Y

 S Y=PSBPRNDT D DD^%DT S PSBRDTA=Y

 W !!!,?10,"**PRN DOCUMENTATION WILL BE FILED FOR THE FOLLOWING**"

 W !!,?5,"PRN START DATE...........: ",PSBRDTA

 W !,?5,"PRN END DATE.............: ",PSBRDT

 W !,?5,"PRN ENTERED BY...........: ",PSBNAME

 W !,?5,"PRN DOCUMENTATION STATEMENT: "

 ;Set mesage to be used

 S PSBPRNM="Administrative Closure"

 I $L(PSBPRNM)>0 D

 .W ?9,$E(PSBPRNM,1,52)

 R !!,"Would you like to CONTINUE ? (Y/N):",PSBANS:30

 S PSBFLAG=""

 I (PSBANS["Y")!(PSBANS="y") S PSBFLAG=1

 I PSBFLAG'=1 D  Q

 .W !!,"You have chosen not to continue! Application ending!!"

 D HEADER

 D ENV(PSBPRNDT,PSBSTRTE,PSBDUZ,PSBPRNM)

 Q

 ;

PROCESS(PSBPRNDT,PSBSTRTE,PSBDUZ,PSBPRNM)  ;

 ;Gather Patient DFN                        

 S PSBSRTD=PSBSTRTE+1

 S PSBPRTA=PSBPRNDT-1

 S PSBCNT="0"

 S DFN=""  F  S DFN=$O(^PSB(53.79,"APRN",DFN)) Q:DFN=""  D 

 .S PSBSTRT="" F  S PSBSTRT=$O(^PSB(53.79,"APRN",DFN,PSBSTRT)) Q:PSBSTRT=""  D

 ..I PSBSTRT>PSBPRTA,PSBSTRT<PSBSRTD  D

 ...S PSBIEN="" F  S PSBIEN=$O(^PSB(53.79,"APRN",DFN,PSBSTRT,PSBIEN)) Q:'PSBIEN  D

 ....I ($P(^PSB(53.79,PSBIEN,0),U,9)'="G")&($P(^PSB(53.79,PSBIEN,0),U,9)'="RM") Q    ;Med was never given

 ....Q:$P($G(^PSB(53.79,PSBIEN,.2)),U,2)]""  ;PRN already entered

 ....D FILEIT(PSBIEN,PSBPRNM)

 ....;increment counter

 ....S PSBCNT=PSBCNT+1

 ;Email the results

 D PSBEMAIL(PSBCNT,PSBPRNM,PSBSTRTE,PSBPRNDT,PSBDUZ)

 K PSBCNT,PSBPRNM,PSBDTA,PSBPRNDT,PSBDUZ,PSBPRMG,PSBSTRTE

 K PSBSRTD,PSBPRTA

 Q

 ;File PRN

FILEIT(PSBIEN,PSBPRNM)   ;

 ;

 S PSBREC(0)=PSBPRNM

 S PSBIEN=PSBIEN_","

 D VAL^PSBML(53.79,PSBIEN,.22,PSBREC(0))

 D FILEIT^PSBML

 Q

 ;

 ;

HEADER ;Header

 W #

 W !,$TR($J("",IOM)," ","-")

 W !,?23,"PRN EFFECTIVENESS DOCUMENTATION ROUTINE"

 W !,$TR($J("",IOM)," ","-")

 Q

 ;

 ;

PSBEMAIL(PSB1,PSB2,PSB3,PSB4,PSB5)        ;

 ; PSB1 = PRN Count

 ; PSB2 = PRN message to file

 ; PSB3 = START date for search

 ; PSB4 = FINISH date for search

 ; PSB5 = DUZ for PRN entered by              

 ; Send PRN documentation changes to user

 S Y=PSB3 D DD^%DT S PSB3X=Y

 S Y=PSB4 D DD^%DT S PSB4X=Y

 S PSB5=$P(^VA(200,PSB5,0),"^",1)

 S PSBMG=DUZ ;

 Q:PSBMG=""

 S PSBMSG(1)=" "

 S PSBMSG(2)="  PRN effectiveness not documented have been fixed. "

 S PSBMSG(3)="  "

 S PSBMSG(4)="  PRN effectiveness entered by.: "_PSB5

 S PSBMSG(5)="  Number of PRNs documented....: "_PSB1

 S PSBMSG(6)="  Start Date.......: "_PSB4X

 S PSBMSG(7)="  Finish Date......: "_PSB3X

 S PSBMSG(8)="  Message documented for PRNs..: "_PSB2

 S PSBMSG(9)="        "

 S PSBMSG(10)="        "

 S PSBMSG(11)="       "

 S PSBMSG(12)=""

 S PSBMSG(13)="     "

 S PSBMSG(14)="     "

 S PSBMSG(15)="                                     "

 S XMY(DUZ)="",XMTEXT="PSBMSG(",XMSUB="BCMA PRN DOCUMENTATION Notification."

 D ^XMD

 K PSB1,PSB2,PSB3,PSB4,PSB5,PSB4X,PSB3X

 K PSBMSG,PSBMG,XMY,XMSUB,XMTEXT

 Q

 ;

 ;

 ;

 ; 

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PSBPRND   4310     printed  Apr 23, 2025@17:55:30                                                                                                                                                                                                     Page 2

PSBPRND   ;BIRMINGHAM/EFC-BCMA PRN DOCUMENTING ;May 2002

 +1       ;;2.0;BAR CODE MED ADMIN;**32**;May 2002

 +2       ;

 +3       ;Queue the routine

ENV(PSBPRNDT,PSBSTRT,PSBDUZ,PRNMSG) ;

 +1        IF $GET(DUZ)=""

               WRITE !,"Your DUZ is not defined. It must be defined."

               QUIT 

 +2        KILL ZTSAVE,ZTSK

           SET ZTRTN="PROCESS^PSBPRND(PSBPRNDT,PSBSTRTE,PSBDUZ,PSBPRNM)"

           SET ZTDESC="BCMA PRN DOCUMENTATION"

           SET ZTIO=""

 +3        WRITE !!

 +4        SET ZTSAVE("PSBPRNDT")=""

 +5        SET ZTSAVE("PSBSTRTE")=""

 +6        SET ZTSAVE("PSBDUZ")=""

 +7        SET ZTSAVE("PSBPRNM")=""

 +8        DO ^%ZTLOAD

 +9        IF $DATA(ZTSK)

               Begin DoDot:1

 +10               WRITE !!,"The PRN effectiveness documenting process was ",$SELECT($GET(ZTSK):"",1:"NOT"),"queued",!

 +11               WRITE !," TASK#: "_$GET(ZTSK)

               End DoDot:1

 +12       QUIT 

PSBPRNS   ;Document all administrations of a PRN order that have NOT had

 +1       ; the PRN Effectiveness documented for dates user provided

 +2       ;

 +3        NEW PSBIEN

 +4        IF $GET(DUZ)=""

               WRITE !,"Your DUZ is not defined. It must be defined."

               QUIT 

 +5        SET PSBDUZ=$GET(DUZ)

 +6        DO HEADER

 +7       ;get start date

 +8        SET %DT="AEQ"

           SET %DT("A")="Select Date to Process From: "

 +9        SET %DT("B")=""

 +10       WRITE !

           DO ^%DT

           if +Y<1

               QUIT 

           SET PSBDT=Y

 +11       SET PSBPRNDT=PSBDT

           DO D^DIQ

 +12      ;Get stop date

 +13       SET %DT="AEQ"

           SET %DT("A")="Select Date to Process Up to: "

 +14       SET %DT("B")=""

 +15       WRITE !

           DO ^%DT

           if +Y<1

               QUIT 

           SET PSBDTA=Y

 +16       SET PSBSTRTE=PSBDTA

           DO D^DIQ

 +17       IF PSBPRNDT>PSBSTRTE

               WRITE !,"Start date cannot be greater than end date"

               QUIT 

 +18      ;Write user running routine

 +19       SET PSBNAME=$PIECE(^VA(200,PSBDUZ,0),"^",1)

 +20       WRITE !!,"PRN effectiveness entered by: ",PSBNAME,!

 +21       DO HEADER

 +22      ;COMMIT OR QUIT

 +23       SET Y=PSBDTA

           DO DD^%DT

           SET PSBRDT=Y

 +24       SET Y=PSBPRNDT

           DO DD^%DT

           SET PSBRDTA=Y

 +25       WRITE !!!,?10,"**PRN DOCUMENTATION WILL BE FILED FOR THE FOLLOWING**"

 +26       WRITE !!,?5,"PRN START DATE...........: ",PSBRDTA

 +27       WRITE !,?5,"PRN END DATE.............: ",PSBRDT

 +28       WRITE !,?5,"PRN ENTERED BY...........: ",PSBNAME

 +29       WRITE !,?5,"PRN DOCUMENTATION STATEMENT: "

 +30      ;Set mesage to be used

 +31       SET PSBPRNM="Administrative Closure"

 +32       IF $LENGTH(PSBPRNM)>0

               Begin DoDot:1

 +33               WRITE ?9,$EXTRACT(PSBPRNM,1,52)

               End DoDot:1

 +34       READ !!,"Would you like to CONTINUE ? (Y/N):",PSBANS:30

 +35       SET PSBFLAG=""

 +36       IF (PSBANS["Y")!(PSBANS="y")

               SET PSBFLAG=1

 +37       IF PSBFLAG'=1

               Begin DoDot:1

 +38               WRITE !!,"You have chosen not to continue! Application ending!!"

               End DoDot:1

               QUIT 

 +39       DO HEADER

 +40       DO ENV(PSBPRNDT,PSBSTRTE,PSBDUZ,PSBPRNM)

 +41       QUIT 

 +42      ;

PROCESS(PSBPRNDT,PSBSTRTE,PSBDUZ,PSBPRNM) ;

 +1       ;Gather Patient DFN                        

 +2        SET PSBSRTD=PSBSTRTE+1

 +3        SET PSBPRTA=PSBPRNDT-1

 +4        SET PSBCNT="0"

 +5        SET DFN=""

           FOR 

               SET DFN=$ORDER(^PSB(53.79,"APRN",DFN))

               if DFN=""

                   QUIT 

               Begin DoDot:1

 +6                SET PSBSTRT=""

                   FOR 

                       SET PSBSTRT=$ORDER(^PSB(53.79,"APRN",DFN,PSBSTRT))

                       if PSBSTRT=""

                           QUIT 

                       Begin DoDot:2

 +7                        IF PSBSTRT>PSBPRTA

                               IF PSBSTRT<PSBSRTD

                                   Begin DoDot:3

 +8                                    SET PSBIEN=""

                                       FOR 

                                           SET PSBIEN=$ORDER(^PSB(53.79,"APRN",DFN,PSBSTRT,PSBIEN))

                                           if 'PSBIEN

                                               QUIT 

                                           Begin DoDot:4

 +9       ;Med was never given

                                               IF ($PIECE(^PSB(53.79,PSBIEN,0),U,9)'="G")&($PIECE(^PSB(53.79,PSBIEN,0),U,9)'="RM")

                                                   QUIT 

 +10      ;PRN already entered

                                               if $PIECE($GET(^PSB(53.79,PSBIEN,.2)),U,2)]""

                                                   QUIT 

 +11                                           DO FILEIT(PSBIEN,PSBPRNM)

 +12      ;increment counter

 +13                                           SET PSBCNT=PSBCNT+1

                                           End DoDot:4

                                   End DoDot:3

                       End DoDot:2

               End DoDot:1

 +14      ;Email the results

 +15       DO PSBEMAIL(PSBCNT,PSBPRNM,PSBSTRTE,PSBPRNDT,PSBDUZ)

 +16       KILL PSBCNT,PSBPRNM,PSBDTA,PSBPRNDT,PSBDUZ,PSBPRMG,PSBSTRTE

 +17       KILL PSBSRTD,PSBPRTA

 +18       QUIT 

 +19      ;File PRN

FILEIT(PSBIEN,PSBPRNM) ;

 +1       ;

 +2        SET PSBREC(0)=PSBPRNM

 +3        SET PSBIEN=PSBIEN_","

 +4        DO VAL^PSBML(53.79,PSBIEN,.22,PSBREC(0))

 +5        DO FILEIT^PSBML

 +6        QUIT 

 +7       ;

 +8       ;

HEADER    ;Header

 +1        WRITE #

 +2        WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")

 +3        WRITE !,?23,"PRN EFFECTIVENESS DOCUMENTATION ROUTINE"

 +4        WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")

 +5        QUIT 

 +6       ;

 +7       ;

PSBEMAIL(PSB1,PSB2,PSB3,PSB4,PSB5) ;

 +1       ; PSB1 = PRN Count

 +2       ; PSB2 = PRN message to file

 +3       ; PSB3 = START date for search

 +4       ; PSB4 = FINISH date for search

 +5       ; PSB5 = DUZ for PRN entered by              

 +6       ; Send PRN documentation changes to user

 +7        SET Y=PSB3

           DO DD^%DT

           SET PSB3X=Y

 +8        SET Y=PSB4

           DO DD^%DT

           SET PSB4X=Y

 +9        SET PSB5=$PIECE(^VA(200,PSB5,0),"^",1)

 +10      ;

           SET PSBMG=DUZ

 +11       if PSBMG=""

               QUIT 

 +12       SET PSBMSG(1)=" "

 +13       SET PSBMSG(2)="  PRN effectiveness not documented have been fixed. "

 +14       SET PSBMSG(3)="  "

 +15       SET PSBMSG(4)="  PRN effectiveness entered by.: "_PSB5

 +16       SET PSBMSG(5)="  Number of PRNs documented....: "_PSB1

 +17       SET PSBMSG(6)="  Start Date.......: "_PSB4X

 +18       SET PSBMSG(7)="  Finish Date......: "_PSB3X

 +19       SET PSBMSG(8)="  Message documented for PRNs..: "_PSB2

 +20       SET PSBMSG(9)="        "

 +21       SET PSBMSG(10)="        "

 +22       SET PSBMSG(11)="       "

 +23       SET PSBMSG(12)=""

 +24       SET PSBMSG(13)="     "

 +25       SET PSBMSG(14)="     "

 +26       SET PSBMSG(15)="                                     "

 +27       SET XMY(DUZ)=""

           SET XMTEXT="PSBMSG("

           SET XMSUB="BCMA PRN DOCUMENTATION Notification."

 +28       DO ^XMD

 +29       KILL PSB1,PSB2,PSB3,PSB4,PSB5,PSB4X,PSB3X

 +30       KILL PSBMSG,PSBMG,XMY,XMSUB,XMTEXT

 +31       QUIT 

 +32      ;

 +33      ;

 +34      ;

 +35      ; 

 +36      ;