PSBIHS1.m

PSBIHS1 ;KF/VAOIT  PSB BCMA MOB ENTRY REPORT 

 ;;1.0;PSB BCMA CPS FOXK;**1018**;;Build 27

ASKDN ;ASK NURSE OR DIVISION

 S DIR(0)="SA^D:DIVISION;N:NURSING UNIT"

 S DIR("A")="Run this report by (D):Division or (N):Nursing Unit: "

 D ^DIR I X="^"!(X="") D STOP Q

 S PSBN=Y

 K DIR,Y,DIR("A"),DIR(0)

 I PSBN="N" D ASKNUR Q

 I PSBN="D" D ASK1 Q

 Q

ASKNUR ;NURSE LOCATION

 S DIC(0)="AEMQMZ",DIC="^NURSF(211.4," D ^DIC I X="^"!(X="") D STOP Q   Q:Y'>0

 S PSBNL=$P(Y,"^",1)

 I $P($G(^NURSF(211.4,PSBNL,1)),"^",1)'="A" W !,"You selePSBCTed a 'INAPSBCTIVE' Nurse Unit Please try again! " H 2 D ASKNUR Q

 D ST2

 Q

ASK1 ;GET DIVS.

 S Y=$$SITE^VASITE

 S PSBDV=$P(Y,"^",1),PSBDVV(PSBDV)=""

ST2 ;START AND END DATES

 S %DT("A")="Enter a Start Date: "

 S %DT="AE"

 D ^%DT I X="^"!(X="") D STOP Q

 S PSBBDATE=Y K %DT,Y

 I PSBBDATE<3030801 D  Q

 .S Y=PSBBDATE D DD^%DT W !,"You entered "_Y_" Start Date must be After 'August 1, 2003" D ST2 Q

 K %DT,Y

END K X

 S %DT("A")="Enter a End Date: ",PSBEDATE=""

 S %DT="AE"

 D ^%DT S PSBEDATE=Y K %DT,Y

 I X=""!(X="^") D STOP Q

 S X1=PSBEDATE,X2=1 D C^%DTC S PSBEDATE=X K X1,X2

 I PSBEDATE<PSBBDATE W !,"End Date must be after the start !" D END Q

 W !,"Print order details CPRS Med Order Button Yes/No?: "

 S %=1 D YN^DICN I X=""!(X="^") D STOP Q

 S PSBREP=0 ;DEFAULT NO

 I %=1 D

 .S PSBREP1=1

 .W !,"Would you like to include comments Yes/No?: "

 .S %=1 D YN^DICN I X=""!(X="^") D STOP Q

 .I %=1 S PSBCOM1=1

 .I %=2 S PSBCOM1=0

 ;.S %=1

 S PSBLN=1

 I %=2 S PSBREP1=0,PSBLN=0

 I '$D(PSBN) S PSBN=""

 I '$D(PSBNL) S PSBNL=""

 I '$D(PSBDV) S PSBDV=""

 I '$D(PSBVISN) S PSBVISN=""

 D TAS

 Q

NTASK ;NIGHT TASK

 S X1=DT,X2=-1 D C^%DTC S PSBBDATE=X K X1,X2

 S PSBREP1=1,X1=DT,X2=1 D C^%DTC S PSBEDATE=X K X1,X2

 S PSBLN=1,PSBN="D"

 S Y=$$SITE^VASITE

 S PSBCOM1=0

 S PSBDV=$P(Y,"^",1),PSBDVV(PSBDV)=""

 I '$D(PSBN) S PSBN=""

 I '$D(PSBNL) S PSBNL=""

 I '$D(PSBDV) S PSBDV=""

 I '$D(PSBVISN) S PSBVISN=""

 U IO

 D NEW

 Q

TAS ;TASK IT OR NOT

 S %ZIS="Q"

 W ! D ^%ZIS K %ZIS

 I POP D  Q

 .W $C(7)

 .K VISN,PSBEDATE,PSBBDATE,PSBDV

 ; output not queued...

 I '$D(IO("Q")) D

 .D WAIT^DICD U IO D NEW

 .I IO'=IO(0) D ^%ZISC

 ; set up the Task...

 I $D(IO("Q")) D

 .N ZTDESC,ZTSAVE,ZTIO,ZTRTN

 .S ZTRTN="NEW^PSBIHS1"

 .S ZTDESC="PSB MOB ENTRY REPORT "

 .S ZTSAVE("PSBBDATE")=""

 .S ZTSAVE("PSBEDATE")=""

 .S ZTSAVE("PSBVISN")=""

 .S ZTSAVE("PSBDV")=""

 .S ZTSAVE("PSBREP1")=""

 .S ZTSAVE("PSBLN")=""

 .S ZTSAVE("PSBN")=""

 .S ZTSAVE("PSBNL")=""

 .S ZTSAVE("PSBDV*")=""

 .S ZTSAVE("PSBCOM1")=""

 .S ZTIO=ION

 .D ^%ZTLOAD

 .D HOME^%ZIS

 .W !,$S($G(ZTSK):"Task number "_ZTSK_" queued.",1:"ERROR -- NOT QUEUED!")

 .K IO("Q"),ZTSK

 Q

NEW ;ALL PRNS

 K ^TMP($J),PSBNONEP

 S PSBCNT=0,PSBNONE=0,PSBCNTP=0,PSBNONEP=0

NUR ;BLUID ARRAY BY NURS LOCATION

 I PSBN="N" D

 .S PSBNWARD=0 F  S PSBNWARD=$O(^NURSF(211.4,PSBNL,3,PSBNWARD)) Q:PSBNWARD=""  D

 ..S PSBNWD=$P($G(^NURSF(211.4,PSBNL,3,PSBNWARD,0)),"^",1)

 ..S PSBNWD($P($G(^DIC(42,PSBNWD,0)),"^",1))=""

DIV1 ;BLGD ARRAY FOR WARDS IN THE DIV SELEPSBCTED

 I PSBN="D" D

 .K ^TMP($J,"DIV")

 .S PSBIEN=0 F  S PSBIEN=$O(^DIC(42,PSBIEN)) Q:PSBIEN'>0   S PSBDIV=$P($G(^DIC(42,PSBIEN,0)),U,11) S:+PSBDIV ^TMP($J,"DIV",PSBDIV,PSBIEN)=""

 .S PSBNUM="" F  S PSBNUM=$O(PSBDVV(PSBNUM)) Q:PSBNUM=""  D

 ..K %,DIC,D,X,Y

 ..S DIC="^DG(40.8,",D="AD",X=PSBNUM,DIC(0)="XN"

 ..D IX^DIC Q:+Y'>0

 ..S PSBDIV1=+Y

 ..K DIC,D,X,Y

 ..;GET WARDS IN MED CENTER DIVION

 ..S PSBWIEN="" F  S PSBWIEN=$O(^TMP($J,"DIV",PSBDIV1,PSBWIEN)) Q:PSBWIEN=""  S PSBNWD($P($G(^DIC(42,PSBWIEN,0)),"^",1))=""

 K ^TMP($J)  ;DONE WITH DIV USE TMP AGAIN

STS ;LOOK IN MED FILE FOR DATA...

 N PSBPSBCTWD,PSBPSBCTWDN,PSBCT,PSBCTN,PSBCTNNLOC,PSBCTNLOC,PSBBC2,PSBLEN,PSBLEN1

 S PSBDFN="" F  S PSBDFN=$O(^PSB(53.79,"AEDT",PSBDFN)) Q:PSBDFN'>0  D

 .S PSBDATE=PSBBDATE F  S PSBDATE=$O(^PSB(53.79,"AEDT",PSBDFN,PSBDATE)) Q:PSBDATE'>0!(PSBDATE>PSBEDATE)  D

 ..S PSBIEN="" F  S PSBIEN=$O(^PSB(53.79,"AEDT",PSBDFN,PSBDATE,PSBIEN)) Q:PSBIEN'>0  D

 ...;CHECK PSBDIV FIRST

 ...S PSBDIV=$P($G(^PSB(53.79,PSBIEN,0)),"^",3)

 ...I PSBDIV="" Q

 ...S PSBLOC1=$P($G(^PSB(53.79,PSBIEN,0)),"^",2)

 ...S PSBSTOP=0

 ...S PSBLOC3="" F  S PSBLOC3=$O(PSBNWD(PSBLOC3)) Q:PSBLOC3=""!(PSBSTOP=1)  D

 ....I PSBLOC1[PSBLOC3 S PSBLEN=$L(PSBLOC3) S PSBLEN1=$E(PSBLOC1,1,PSBLEN) I PSBLOC3=PSBLEN1 S PSBSTOP=1,PSBLOC=PSBLOC3

 ...I PSBSTOP=0 Q

 ...I '$D(PSBPSBCTWD(PSBLOC)) S PSBPSBCTWD(PSBLOC)=0

 ...I '$D(PSBPSBCTWDN(PSBLOC)) S PSBPSBCTWDN(PSBLOC)=0

 ...I '$D(PSBCT(PSBDIV)) S PSBCT(PSBDIV)=0

 ...I '$D(PSBCTN(PSBDIV)) S PSBCTN(PSBDIV)=0

 ...S PSBWIEN=$O(^DIC(42,"B",PSBLOC,"")),PSBWDNU=""

 ...S PSBNLOCC="" F  S PSBNLOCC=$O(^NURSF(211.4,"C",PSBWIEN,PSBNLOCC)) Q:PSBNLOCC=""  D

 ....I $P($G(^NURSF(211.4,PSBNLOCC,1)),"^",1)="A" S PSBWDNU=$P($G(^SC($P($G(^NURSF(211.4,PSBNLOCC,0)),"^",1),0)),"^",1),PSBNLOC=PSBNLOCC

 ...I '$D(PSBCTNLOC(PSBNLOC)) S PSBCTNLOC(PSBNLOC)=0

 ...I '$D(PSBCTNNLOC(PSBNLOC)) S PSBCTNNLOC(PSBNLOC)=0

 ...I '$D(PSBCTNLOCP(PSBNLOC)) S PSBCTNLOCP(PSBNLOC)=0

 ...I '$D(PSBCTNNLOCP(PSBNLOC)) S PSBCTNNLOCP(PSBNLOC)=0

 ...S PSBBC2=0

 ...S PSBCNT=PSBCNT+1,PSBCT(PSBDIV)=PSBCT(PSBDIV)+1,PSBPSBCTWD(PSBLOC)=PSBPSBCTWD(PSBLOC)+1,PSBCTNLOC(PSBNLOC)=PSBCTNLOC(PSBNLOC)+1

 ...F PSBH=1:1:$P($G(^PSB(53.79,PSBIEN,.3,0)),"^",4) D

 ....I $G(^PSB(53.79,PSBIEN,.3,PSBH,0))["BCMA/CPRS Interface Entry" S PSBBC2=1,PSBNONE=PSBNONE+1,PSBCTN(PSBDIV)=PSBCTN(PSBDIV)+1,PSBCTNNLOC(PSBNLOC)=PSBCTNNLOC(PSBNLOC)+1,PSBPSBCTWDN(PSBLOC)=PSBPSBCTWDN(PSBLOC)+1

 ....I PSBBC2=1 D

 .....S PSBNAME=$P($G(^DPT($P($G(^PSB(53.79,PSBIEN,0)),"^",1),0)),"^",1)

 .....I PSBWDNU="" S PSBWDNU="NO 'N.U.' FOR WARD"

 .....S ^TMP($J,"PRN",PSBDIV,PSBWDNU,PSBLOC,PSBNAME,PSBIEN)=$G(^PSB(53.79,PSBIEN,0))

REP ;DISPLAY DATA

 W @IOF

 W !,?15,"BCMA/EHR Med Order Button From " S Y=PSBBDATE D DD^%DT W Y_" TO " S X1=PSBEDATE,X2=-1 D C^%DTC S Y=X D DD^%DT S PSBREPT=Y  W PSBREPT

 D NOW^%DTC S Y=% D DD^%DT S PSBRT=Y W !,?65,"Run Date/Time:"_PSBRT

 I PSBN="D" D

 .W !,?5,"SITE",?25,"TOTAL Med Logs",?45,"BCMA/CPRS Med Order Button Entry" ;?65,"% GUI Entered"

 .W ! F J=1:1:IOM W "-"

 .I PSBCNT=0 W !,"NONE FOUND" Q

 .S PSBDIV="" F J=0:0 S PSBDIV=$O(PSBCT(PSBDIV)) Q:PSBDIV=""  D

 ..W !,$P($G(^DIC(4,PSBDIV,0)),"^",1)

 ..S PSBDT=$G(PSBCT(PSBDIV)),PSBDTN=$G(PSBCTN(PSBDIV)),PSBDD=PSBDT-PSBDTN

 ..I PSBDT>0 S PSBDPER=(PSBDD/PSBDT)*100

 ..I PSBDT=0 S PSBDPER=0

 ..W ?30,PSBDT,?50,PSBDTN ;?76,$E(PSBDPER,1,6)_"%"

 .W ! F J=1:1:IOM W "-"

 .S PSBDD=PSBCNT-PSBNONE,PSBTPER=(PSBDD/PSBCNT)*100

 .W !,"TOTALS",?30,PSBCNT,?50,PSBNONE ;,?76,$E(PSBTPER,1,6)_"%"

 .;WARD TOTALS

 .W !!!,?5,"WARD",?25,"TOTAL Med Logs",?45,"BCMA/CPRS Med Order Button Entry"  ;,?70,"% GUI Entered"

 .W ! F J=1:1:IOM W "-"

 .I PSBCNT=0 W !,"NONE FOUND" Q

 .S PSBWARD="" F J=0:0 S PSBWARD=$O(PSBPSBCTWD(PSBWARD)) Q:PSBWARD=""  D

 ..W !,PSBWARD

 ..S PSBDT=$G(PSBPSBCTWD(PSBWARD)),PSBDTN=$G(PSBPSBCTWDN(PSBWARD)),PSBDD=PSBDT-PSBDTN

 ..I PSBDT>0 S PSBDPER=(PSBDD/PSBDT)*100

 ..I PSBDT=0 S PSBDPER=0

 ..W ?30,PSBDT,?50,PSBDTN ;?76,$E(PSBDPER,1,6)_"%"

 .W ! F J=1:1:IOM W "-"

 ;Nursing Unit

 I PSBN="N" D

 .W !!,"By Nursing Unit"

 .W !!!,?5,"Nurse Unit",?25,"TOTAL Med Logs",?45,"BCMA/CPRS Med Order Button Entry" ;,?70,"% GUI Entered"

 .W ! F J=1:1:IOM W "-"

 .I PSBCNT=0 W !,"NONE FOUND" Q

 .S PSBNUT="" F  S PSBNUT=$O(PSBCTNLOC(PSBNUT)) Q:PSBNUT=""  D

 ..S PSBNUT1=PSBNUT

 ..S PSBNUTN=$P($G(^NURSF(211.4,PSBNUT,0)),"^",1),PSBNUTN=$P($G(^SC(PSBNUTN,0)),"^",1) W !,PSBNUTN

 ..S PSBDT=$G(PSBCTNLOC(PSBNUT)),PSBDTN=$G(PSBCTNNLOC(PSBNUT)),PSBDD=PSBDT-PSBDTN

 ..I PSBDT>0 S PSBDPER=(PSBDD/PSBDT)*100

 ..I PSBDT=0 S PSBDPER=0

 ..W ?30,PSBDT,?50,PSBDTN ;,?76,$E(PSBDPER,1,6)_"%"

 .S PSBNUTN=$P($G(^NURSF(211.4,PSBNUT1,0)),"^",1),PSBNUTN=$P($G(^SC(PSBNUTN,0)),"^",1) W !,PSBNUTN

 .S PSBDT=$G(PSBCTNLOCP(PSBNUT1)),PSBDTN=$G(PSBCTNNLOCP(PSBNUT1)),PSBDD=PSBDT-PSBDTN

 .I PSBDT>0 S PSBDPER=(PSBDD/PSBDT)*100

 .I PSBDT=0 S PSBDPER=0

 .W ?30,PSBDT,?50,PSBDTN ;,?76,$E(PSBDPER,1,6)_"%"

 .W ! F J=1:1:IOM W "-"

 .I PSBCNT=0 W !,"NONE FOUND" Q

 .S PSBDD=PSBCNT-PSBNONE,PSBTPER=(PSBDD/PSBCNT)*100

 .W !,"Report Totals",?30,PSBCNT,?50,PSBNONE ;,?76,$E(PSBTPER,1,6)_"%",!

 .I PSBDT=0 S PSBDPER=0

 I PSBREP1=1 D REP1

 D STOP

 Q

HEAD W @IOF

 W !,?15,"BCMA/CPRS Interface Entry in BCMA From " S Y=PSBBDATE D DD^%DT W Y_" TO " W PSBREPT

 W !,"Nurse Unit: "_PSBWDNU,?65,"Run Date/Time: "_PSBRT

 I PSBLN=0 W !,"NAME",?30,"HRN",?45,"DATE/TIME"

 I PSBLN=1 W !,"NAME",?30,"HRN",?45,"DATE/TIME",?65,"ADMIN BY"

 W ! F J=1:1:IOM W "-"

 K %

 Q

REP1 S PSBWDNU=0

 S PSBDIV="" F J=0:0 S PSBDIV=$O(^TMP($J,"PRN",PSBDIV)) Q:PSBDIV=""  D

 .S PSBWDNU="" F J=0:0 S PSBWDNU=$O(^TMP($J,"PRN",PSBDIV,PSBWDNU)) Q:PSBWDNU=""  D

 ..I '$D(PSBONU) S PSBONU=PSBWDNU D HEAD

 ..I PSBWDNU'=PSBONU D HEAD

 ..S PSBLOC="" F J=0:0 S PSBLOC=$O(^TMP($J,"PRN",PSBDIV,PSBWDNU,PSBLOC)) Q:PSBLOC=""  D

 ...F PSBNAME="" F J=0:0 S PSBNAME=$O(^TMP($J,"PRN",PSBDIV,PSBWDNU,PSBLOC,PSBNAME)) Q:PSBNAME=""  D

 ....S PSBIEN="" F J=1:1 S PSBIEN=$O(^TMP($J,"PRN",PSBDIV,PSBWDNU,PSBLOC,PSBNAME,PSBIEN)) Q:PSBIEN=""  D

 .....I $Y>(IOSL-4) D HEAD

 .....S DFN=$P($G(^TMP($J,"PRN",PSBDIV,PSBWDNU,PSBLOC,PSBNAME,PSBIEN)),"^",1)

 .....D DEM^VADPT,PID^VADPT

 .....S PSBPID=$S(DUZ("AG")="I":(VA("PID")),1:$E(VA("PID"),$L(VA("PID"))-3,999))

 .....S Y=$P($G(^TMP($J,"PRN",PSBDIV,PSBWDNU,PSBLOC,PSBNAME,PSBIEN)),"^",6) D DD^%DT S PSBMT=Y

 .....S PSBDRUG=$P($G(^PS(50.7,$P($G(^TMP($J,"PRN",PSBDIV,PSBWDNU,PSBLOC,PSBNAME,PSBIEN)),"^",8),0)),"^",1) S PSBDRUG=$E(PSBDRUG,1,35)

 .....S PSBNUR=$P($G(^TMP($J,"PRN",PSBDIV,PSBWDNU,PSBLOC,PSBNAME,PSBIEN)),"^",7) S PSBNUR=$P($G(^VA(200,PSBNUR,0)),"^",1) S PSBNUR=$E(PSBNUR,1,32)

 .....I PSBLN=0 W !,PSBNAME,?30,PSBPID,?40,PSBMT

 .....I PSBLN=1 W !,PSBNAME,?30,PSBPID,?40,PSBMT,?63,PSBNUR,!,?15,"Medication: ",PSBDRUG,?50,"Dosage: ",$P($G(^PSB(53.79,PSBIEN,.1)),"^",5)

 .....D ORNUM ;PRINT IEN FROM 100

 .....I $D(^PSB(53.79,PSBIEN,.6,0)) D

 ......W !,?15,"Additives:"

 ......F J=1:1:$P(^PSB(53.79,PSBIEN,.6,0),"^",4) W !,?27,$P(^PSB(53.79,PSBIEN,.6,J,0),"^",2),"  ",$P(^PSB(53.79,PSBIEN,.6,J,0),"^",3)

 .....I $D(^PSB(53.79,PSBIEN,.7,0)) D

 ......W !,?15,"Solutions:"

 ......F J=1:1:$P(^PSB(53.79,PSBIEN,.7,0),"^",4) W !,?27,$P(^PSB(53.79,PSBIEN,.7,J,0),"^",2),"  ",$P(^PSB(53.79,PSBIEN,.7,J,0),"^",3)

 .....I PSBCOM1=1 D COM

 .....W !

 ..S PSBONU=PSBWDNU

 D STOP Q

COM ;LOOPS FOR COMMENTS HELD

 N PSBNUM,PSBCOMB,PSBCOMT,PSBCOM

 W !,?15,"Comments:---------------------------------------------------------"

 S PSBNUM=0 F  S PSBNUM=$O(^PSB(53.79,PSBIEN,.3,PSBNUM)) Q:PSBNUM'>0  D

 .S PSBCOM=$P($G(^PSB(53.79,PSBIEN,.3,PSBNUM,0)),"^",1)

 .S PSBCOMB=$P($G(^PSB(53.79,PSBIEN,.3,PSBNUM,0)),"^",2) S PSBCOMB=$P($G(^VA(200,PSBCOMB,0)),"^",2)

 .S Y=$P($G(^PSB(53.79,PSBIEN,.3,PSBNUM,0)),"^",3) D DD^%DT S PSBCOMT=Y

 .W !,?25,PSBCOMT_"  "_PSBCOMB

 .W !,?25,PSBCOM

 W !,?25,"---------------------------------------------------------"

 Q

ORNUM ;GET CPRS ORDER NUMBER

 S PSBORN=$P($G(^PSB(53.79,PSBIEN,.1)),"^",1)

 I PSBORN["U" S PSBORN=$P($G(^PS(55,DFN,5,+PSBORN,0)),"^",21)

 I PSBORN["V" S PSBORN=$P($G(^PS(55,DFN,"IV",+PSBORN,0)),"^",21)

 W !,?15,"EHR Order Number: ",PSBORN

 Q

STOP ;

 K PSBDATE,PSBDFN,PSBDPER,PSBDT,PSBDTN,PSBEDATE,PSBBDATE,PSBLOC,PSBNAME,PSBSSN,PSBMT,PSBLOC3,PSBNUT1

 K PSBDRUG,PSBNONE,PSBVISN,PSBTPER,J,PSBIEN,PSBDIV,PSBOWD,PSBWD,PSBRT,PSBREP1,PSBREPT,PSBWARD,PSBPSBCTWD,PSBPSBCTWDN,PSBDD,PSBNUR,PSBLN,PSBNL,PSBN,PSBNWD,PSBNWARD,PSBDV,DIC,DIR,PSBSTOP

 K PSBLOC1,PSBLOC2,PSBNLOC,PSBNLOCC,PSBNUT,PSBNUTN,PSBWIEN,POP,PSBCTNLOC,PSBCTNNLOC,PSBF,PSBWD,PSBWDIEN,PSBWDNU,PSBONU,PSBNS,PSBDIV1,PSBDVV,PSBNUM,PSBPID,PSBREP

 K PSBCNT,PSBCNTP,PSBCTNLOCP,PSBCTNNLOCP,DFN,PSBH,PSBORN,PSBCOM1,PSBNONEP

Q Q

PSBIHS1   ;KF/VAOIT  PSB BCMA MOB ENTRY REPORT 

 +1       ;;1.0;PSB BCMA CPS FOXK;**1018**;;Build 27

ASKDN     ;ASK NURSE OR DIVISION

 +1        SET DIR(0)="SA^D:DIVISION;N:NURSING UNIT"

 +2        SET DIR("A")="Run this report by (D):Division or (N):Nursing Unit: "

 +3        DO ^DIR

           IF X="^"!(X="")

               DO STOP

               QUIT 

 +4        SET PSBN=Y

 +5        KILL DIR,Y,DIR("A"),DIR(0)

 +6        IF PSBN="N"

               DO ASKNUR

               QUIT 

 +7        IF PSBN="D"

               DO ASK1

               QUIT 

 +8        QUIT 

ASKNUR    ;NURSE LOCATION

 +1        SET DIC(0)="AEMQMZ"

           SET DIC="^NURSF(211.4,"

           DO ^DIC

           IF X="^"!(X="")

               DO STOP

               QUIT 

               IF Y'>0

                   QUIT 

 +2        SET PSBNL=$PIECE(Y,"^",1)

 +3        IF $PIECE($GET(^NURSF(211.4,PSBNL,1)),"^",1)'="A"

               WRITE !,"You selePSBCTed a 'INAPSBCTIVE' Nurse Unit Please try again! "

               HANG 2

               DO ASKNUR

               QUIT 

 +4        DO ST2

 +5        QUIT 

ASK1      ;GET DIVS.

 +1        SET Y=$$SITE^VASITE

 +2        SET PSBDV=$PIECE(Y,"^",1)

           SET PSBDVV(PSBDV)=""

ST2       ;START AND END DATES

 +1        SET %DT("A")="Enter a Start Date: "

 +2        SET %DT="AE"

 +3        DO ^%DT

           IF X="^"!(X="")

               DO STOP

               QUIT 

 +4        SET PSBBDATE=Y

           KILL %DT,Y

 +5        IF PSBBDATE<3030801

               Begin DoDot:1

 +6                SET Y=PSBBDATE

                   DO DD^%DT

                   WRITE !,"You entered "_Y_" Start Date must be After 'August 1, 2003"

                   DO ST2

                   QUIT 

               End DoDot:1

               QUIT 

 +7        KILL %DT,Y

END        KILL X

 +1        SET %DT("A")="Enter a End Date: "

           SET PSBEDATE=""

 +2        SET %DT="AE"

 +3        DO ^%DT

           SET PSBEDATE=Y

           KILL %DT,Y

 +4        IF X=""!(X="^")

               DO STOP

               QUIT 

 +5        SET X1=PSBEDATE

           SET X2=1

           DO C^%DTC

           SET PSBEDATE=X

           KILL X1,X2

 +6        IF PSBEDATE<PSBBDATE

               WRITE !,"End Date must be after the start !"

               DO END

               QUIT 

 +7        WRITE !,"Print order details CPRS Med Order Button Yes/No?: "

 +8        SET %=1

           DO YN^DICN

           IF X=""!(X="^")

               DO STOP

               QUIT 

 +9       ;DEFAULT NO

           SET PSBREP=0

 +10       IF %=1

               Begin DoDot:1

 +11               SET PSBREP1=1

 +12               WRITE !,"Would you like to include comments Yes/No?: "

 +13               SET %=1

                   DO YN^DICN

                   IF X=""!(X="^")

                       DO STOP

                       QUIT 

 +14               IF %=1

                       SET PSBCOM1=1

 +15               IF %=2

                       SET PSBCOM1=0

               End DoDot:1

 +16      ;.S %=1

 +17       SET PSBLN=1

 +18       IF %=2

               SET PSBREP1=0

               SET PSBLN=0

 +19       IF '$DATA(PSBN)

               SET PSBN=""

 +20       IF '$DATA(PSBNL)

               SET PSBNL=""

 +21       IF '$DATA(PSBDV)

               SET PSBDV=""

 +22       IF '$DATA(PSBVISN)

               SET PSBVISN=""

 +23       DO TAS

 +24       QUIT 

NTASK     ;NIGHT TASK

 +1        SET X1=DT

           SET X2=-1

           DO C^%DTC

           SET PSBBDATE=X

           KILL X1,X2

 +2        SET PSBREP1=1

           SET X1=DT

           SET X2=1

           DO C^%DTC

           SET PSBEDATE=X

           KILL X1,X2

 +3        SET PSBLN=1

           SET PSBN="D"

 +4        SET Y=$$SITE^VASITE

 +5        SET PSBCOM1=0

 +6        SET PSBDV=$PIECE(Y,"^",1)

           SET PSBDVV(PSBDV)=""

 +7        IF '$DATA(PSBN)

               SET PSBN=""

 +8        IF '$DATA(PSBNL)

               SET PSBNL=""

 +9        IF '$DATA(PSBDV)

               SET PSBDV=""

 +10       IF '$DATA(PSBVISN)

               SET PSBVISN=""

 +11       USE IO

 +12       DO NEW

 +13       QUIT 

TAS       ;TASK IT OR NOT

 +1        SET %ZIS="Q"

 +2        WRITE !

           DO ^%ZIS

           KILL %ZIS

 +3        IF POP

               Begin DoDot:1

 +4                WRITE $CHAR(7)

 +5                KILL VISN,PSBEDATE,PSBBDATE,PSBDV

               End DoDot:1

               QUIT 

 +6       ; output not queued...

 +7        IF '$DATA(IO("Q"))

               Begin DoDot:1

 +8                DO WAIT^DICD

                   USE IO

                   DO NEW

 +9                IF IO'=IO(0)

                       DO ^%ZISC

               End DoDot:1

 +10      ; set up the Task...

 +11       IF $DATA(IO("Q"))

               Begin DoDot:1

 +12               NEW ZTDESC,ZTSAVE,ZTIO,ZTRTN

 +13               SET ZTRTN="NEW^PSBIHS1"

 +14               SET ZTDESC="PSB MOB ENTRY REPORT "

 +15               SET ZTSAVE("PSBBDATE")=""

 +16               SET ZTSAVE("PSBEDATE")=""

 +17               SET ZTSAVE("PSBVISN")=""

 +18               SET ZTSAVE("PSBDV")=""

 +19               SET ZTSAVE("PSBREP1")=""

 +20               SET ZTSAVE("PSBLN")=""

 +21               SET ZTSAVE("PSBN")=""

 +22               SET ZTSAVE("PSBNL")=""

 +23               SET ZTSAVE("PSBDV*")=""

 +24               SET ZTSAVE("PSBCOM1")=""

 +25               SET ZTIO=ION

 +26               DO ^%ZTLOAD

 +27               DO HOME^%ZIS

 +28               WRITE !,$SELECT($GET(ZTSK):"Task number "_ZTSK_" queued.",1:"ERROR -- NOT QUEUED!")

 +29               KILL IO("Q"),ZTSK

               End DoDot:1

 +30       QUIT 

NEW       ;ALL PRNS

 +1        KILL ^TMP($JOB),PSBNONEP

 +2        SET PSBCNT=0

           SET PSBNONE=0

           SET PSBCNTP=0

           SET PSBNONEP=0

NUR       ;BLUID ARRAY BY NURS LOCATION

 +1        IF PSBN="N"

               Begin DoDot:1

 +2                SET PSBNWARD=0

                   FOR 

                       SET PSBNWARD=$ORDER(^NURSF(211.4,PSBNL,3,PSBNWARD))

                       IF PSBNWARD=""

                           QUIT 

                       Begin DoDot:2

 +3                        SET PSBNWD=$PIECE($GET(^NURSF(211.4,PSBNL,3,PSBNWARD,0)),"^",1)

 +4                        SET PSBNWD($PIECE($GET(^DIC(42,PSBNWD,0)),"^",1))=""

                       End DoDot:2

               End DoDot:1

DIV1      ;BLGD ARRAY FOR WARDS IN THE DIV SELEPSBCTED

 +1        IF PSBN="D"

               Begin DoDot:1

 +2                KILL ^TMP($JOB,"DIV")

 +3                SET PSBIEN=0

                   FOR 

                       SET PSBIEN=$ORDER(^DIC(42,PSBIEN))

                       IF PSBIEN'>0

                           QUIT 

                       SET PSBDIV=$PIECE($GET(^DIC(42,PSBIEN,0)),U,11)

                       IF +PSBDIV

                           SET ^TMP($JOB,"DIV",PSBDIV,PSBIEN)=""

 +4                SET PSBNUM=""

                   FOR 

                       SET PSBNUM=$ORDER(PSBDVV(PSBNUM))

                       IF PSBNUM=""

                           QUIT 

                       Begin DoDot:2

 +5                        KILL %,DIC,D,X,Y

 +6                        SET DIC="^DG(40.8,"

                           SET D="AD"

                           SET X=PSBNUM

                           SET DIC(0)="XN"

 +7                        DO IX^DIC

                           IF +Y'>0

                               QUIT 

 +8                        SET PSBDIV1=+Y

 +9                        KILL DIC,D,X,Y

 +10      ;GET WARDS IN MED CENTER DIVION

 +11                       SET PSBWIEN=""

                           FOR 

                               SET PSBWIEN=$ORDER(^TMP($JOB,"DIV",PSBDIV1,PSBWIEN))

                               IF PSBWIEN=""

                                   QUIT 

                               SET PSBNWD($PIECE($GET(^DIC(42,PSBWIEN,0)),"^",1))=""

                       End DoDot:2

               End DoDot:1

 +12      ;DONE WITH DIV USE TMP AGAIN

           KILL ^TMP($JOB)

STS       ;LOOK IN MED FILE FOR DATA...

 +1        NEW PSBPSBCTWD,PSBPSBCTWDN,PSBCT,PSBCTN,PSBCTNNLOC,PSBCTNLOC,PSBBC2,PSBLEN,PSBLEN1

 +2        SET PSBDFN=""

           FOR 

               SET PSBDFN=$ORDER(^PSB(53.79,"AEDT",PSBDFN))

               IF PSBDFN'>0

                   QUIT 

               Begin DoDot:1

 +3                SET PSBDATE=PSBBDATE

                   FOR 

                       SET PSBDATE=$ORDER(^PSB(53.79,"AEDT",PSBDFN,PSBDATE))

                       IF PSBDATE'>0!(PSBDATE>PSBEDATE)

                           QUIT 

                       Begin DoDot:2

 +4                        SET PSBIEN=""

                           FOR 

                               SET PSBIEN=$ORDER(^PSB(53.79,"AEDT",PSBDFN,PSBDATE,PSBIEN))

                               IF PSBIEN'>0

                                   QUIT 

                               Begin DoDot:3

 +5       ;CHECK PSBDIV FIRST

 +6                                SET PSBDIV=$PIECE($GET(^PSB(53.79,PSBIEN,0)),"^",3)

 +7                                IF PSBDIV=""

                                       QUIT 

 +8                                SET PSBLOC1=$PIECE($GET(^PSB(53.79,PSBIEN,0)),"^",2)

 +9                                SET PSBSTOP=0

 +10                               SET PSBLOC3=""

                                   FOR 

                                       SET PSBLOC3=$ORDER(PSBNWD(PSBLOC3))

                                       IF PSBLOC3=""!(PSBSTOP=1)

                                           QUIT 

                                       Begin DoDot:4

 +11                                       IF PSBLOC1[PSBLOC3

                                               SET PSBLEN=$LENGTH(PSBLOC3)

                                               SET PSBLEN1=$EXTRACT(PSBLOC1,1,PSBLEN)

                                               IF PSBLOC3=PSBLEN1

                                                   SET PSBSTOP=1

                                                   SET PSBLOC=PSBLOC3

                                       End DoDot:4

 +12                               IF PSBSTOP=0

                                       QUIT 

 +13                               IF '$DATA(PSBPSBCTWD(PSBLOC))

                                       SET PSBPSBCTWD(PSBLOC)=0

 +14                               IF '$DATA(PSBPSBCTWDN(PSBLOC))

                                       SET PSBPSBCTWDN(PSBLOC)=0

 +15                               IF '$DATA(PSBCT(PSBDIV))

                                       SET PSBCT(PSBDIV)=0

 +16                               IF '$DATA(PSBCTN(PSBDIV))

                                       SET PSBCTN(PSBDIV)=0

 +17                               SET PSBWIEN=$ORDER(^DIC(42,"B",PSBLOC,""))

                                   SET PSBWDNU=""

 +18                               SET PSBNLOCC=""

                                   FOR 

                                       SET PSBNLOCC=$ORDER(^NURSF(211.4,"C",PSBWIEN,PSBNLOCC))

                                       IF PSBNLOCC=""

                                           QUIT 

                                       Begin DoDot:4

 +19                                       IF $PIECE($GET(^NURSF(211.4,PSBNLOCC,1)),"^",1)="A"

                                               SET PSBWDNU=$PIECE($GET(^SC($PIECE($GET(^NURSF(211.4,PSBNLOCC,0)),"^",1),0)),"^",1)