PSBMMRB ;AITC/CR - REPORT FOR RESPIRATORY THERAPY MEDS ;11/29/18 5:37am
;;3.0;BAR CODE MED ADMIN;**103**;Mar 2004;Build 21
;Per VA Directive 6402, this routine should not be modified.
;
; Reference/ICR #
; ^DPT("CN"/6984 (private)
; $$GET1^DIQ/2056 (supported)
; ^DG(40.8/2817 (controlled)
; ^DG(43/6812 (private)
; File #44/10040 (supported)
; ^VA(200/10060 (supported)
; %ZTLOAD/10063 (supported)
; %ZIS/10086 (supported)
; %ZISC/10089 (supported)
;
;=================================================================
EN1 ;
W !!,"Report for Respiratory Therapy Medications",!
N D0,DIC,PSBDATA,PSBDPTR,PSBDIV,PSBDVNM,PSBNAME,PSBMUDV,PSBSTIEN,X,Y
K ^TMP($J),^TMP("PSBMMRB")
S D0=1,PSBMUDV=$S($$GET1^DIQ(43,D0,11,"I")=1:1,1:0)
I PSBMUDV=1 D CHK1,EN2 Q
I PSBMUDV=0 D ALL,EN2 Q
Q
;
EN2 I $P($G(^VA(200,DUZ,2,0)),U,4)=0 W !!,$C(7),"You have no valid divisions in the NEW PERSON file." S Y="^" Q
I '$O(^DG(40.8,"AD",DUZ(2),"")) W !!,$C(7),"Your NEW PERSON file division was not found in the MEDICAL CENTER DIVISION file." S Y="^" Q
I Y=""!(Y<0)!(Y="^") Q
S PSBDIV=$P($G(^TMP("PSBMMRB",$J)),U,2)
S PSBNAME=$P($G(^TMP("PSBMMRB",$J)),U,3)
W !
S %DT="AE"
S %DT("A")="Select date of Respiratory Therapy Meds Report (e.g., T or T-1, etc.): "
D ^%DT
I Y'=-1 D
. S RDATE=Y
. W !!,"Please choose a 132 character printer",!
. W "Queuing of this report is recommended",!
. S %ZIS="MQ"
. D ^%ZIS
. I POP K %ZIS W !,"Device not ready" Q
. I $D(IO("Q")) D
.. S ZTRTN="EN3^PSBMMRB"
.. S ZTSAVE("RDATE")=""
.. S ZTSAVE("PSBMUDV")=""
.. S ZTSAVE("PSBDIV")=""
.. S ZTSAVE("PSBNAME")=""
.. S ZTDESC("Respiratory Therapy Meds Report")=""
.. D ^%ZTLOAD
. ; allow user to send report immediately to the screen
. I '$D(IO("Q")) D
.. D WAIT^DICD U IO D EN3^PSBMMRB
.. I IO'=IO(0) D ^%ZISC
D ^%ZISC
D EXIT
Q
;
EN3 ; create new entry; note: national routine PSBO1 is modified for a new report,
; at NEW+3^PSBO1 add RT code for Respiratory Therapy Meds report
;
D NEW^PSBO1(.PSBRPT,"RT") ;for Respiratory Therapy Meds report
G:$P($G(PSBRPT(0)),U)<1 EXIT
; edit new entry.
S DA=$P($G(PSBRPT(0)),U),DIE="^PSB(53.69,"
S DR=".06///^S X=ION;.11///W;.15=///B;.16=///"_RDATE_";.17=///0001;.19=///2400"
L +(^PSB(53.69,DA)):$S($G(DILOCKTM)>30:DILOCKTM,1:30) I '$T G EXIT
D ^DIE
L -(^PSB(53.69,DA))
; loop thru ^DPT("CN" and get all wards with patients
; ZZA is the ward name, ZZB is the IEN for the patient
N ZZA,ZZB,WARD
S ZZA="" F S ZZA=$O(^DPT("CN",ZZA)) Q:ZZA="" D
. N DIVPTR,PSBSTA42,ZZAIEN
. S ZZB="" F S ZZB=$O(^DPT("CN",ZZA,ZZB)) Q:ZZB="" D
.. S ZZAIEN=$O(^SC("B",ZZA,""))
.. Q:+$G(ZZAIEN)=""
.. S DIVPTR=$$GET1^DIQ(44,ZZAIEN,3.5,"I") ; station # for ward
.. S PSBSTA42=$$GET1^DIQ(40.8,DIVPTR,.07,"I")
.. ; capture the ward name
.. S WARD=$$GET1^DIQ(44,ZZAIEN,.01,"E") ; ward name
.. I (PSBMUDV=1)&(PSBDIV'=PSBSTA42) Q ; single division only
.. S ^TMP($J,WARD)=""
;
; if there are no wards in the division queried, issue a blank report
I '$D(^TMP($J)) D Q
. S PSBHDR(1)="RESPIRATORY THERAPY MEDICATIONS from "_$$FMTE^XLFDT(DT)_"@00:01"_" thru "_$$FMTE^XLFDT(DT)_"@24:00"
. S PSBWRD=""
. D WRDHDR^PSBORT
. W !,"No Medications Found"
. Q
;
N NUM,NURIEN,WARD1,WARD2
D NWLIST^PSBRPC(.WARD1,) ; get only active wards from #211.4
S NUM=0 F S NUM=$O(WARD1(NUM)) Q:NUM'>0 I $P($G(WARD1(NUM)),U,2)["[MAS WARD]" S WARD2($P($P($G(WARD1(NUM)),U,2),"[",1))=$P($G(WARD1(NUM)),U,1)
N FLAGPRT ; used in PSBORT to track wards printed
S FLAGPRT=""
S WARD="" F S WARD=$O(^TMP($J,WARD)) Q:WARD="" D
. N SUB
. S SUB=$O(WARD2(WARD))
. S NURIEN=$P($G(WARD2(SUB)),U)
. S DA=$P($G(PSBRPT(0)),U),DIE="^PSB(53.69,"
. S DR=".13////^S X=NURIEN" ; don't prompt when finding similar ward names
. L +(^PSB(53.69,DA)):$S($G(DILOCKTM)>30:DILOCKTM,1:30) I '$T G EXIT
. D ^DIE
. L -(^PSB(53.69,DA))
. D DQ^PSBO(DA)
Q
;
EXIT ; clean up.
K DA,DIE,DR,PSBRPT,RDATE
K D0,^TMP($J),^TMP("PSBMMRB",$J)
Q
;
CHK1 ; The user must have at least one division from file #40.8 in his file #200 record.
N DIR
W !
S DIR(0)="SB^A:All Divisions;O:One Division"
S DIR("?")="Select either All Divisions or One Division."
S DIR("A")="Do you want (A)ll Divisions or just (O)ne Division"
S DIR("B")="O"
D ^DIR K DIR I $D(DUOUT)!$D(DTOUT)!$D(DIROUT)!$D(DIRUT) Q
I Y="" Q
I Y(0)="One Division" D ONE Q ; regardless user divisions in file #200
I Y(0)="All Divisions" S PSBMUDV=2 ; for all divisions in a multisite setup
Q
;
ALL ; user gets all divisions
S Y(0)="All Divisions" ; all divisions selected
S PSBDIV=DUZ(2)
S PSBSTIEN=+$O(^DG(40.8,"AD",DUZ(2),"")) ; current IEN for station
S Y=$$GET1^DIQ(40.8,PSBSTIEN,.01,"E")
I '$D(Y) S Y=DUZ(2)
S PSBNAME=$$NAME^XUAF4(DUZ(2))
S PSBMUDV=0
S ^TMP("PSBMMRB",$J)=PSBMUDV_U_PSBDIV_U_PSBNAME
Q
;
ONE ; when user selects one division from many in file #200, look at file #40.8 for a match if available
W !
S PSBSTIEN=+$O(^DG(40.8,"AD",DUZ(2),"")) ; current IEN for station
S PSBDVNM=$$GET1^DIQ(40.8,PSBSTIEN,.01,"I") ;division name
S DIC("B")=PSBDVNM
S DIC("A")="Select Division: ",DIC="^DG(40.8,",DIC(0)="AEMQ",DIC("S")="I $$SITE^VASITE(,+Y)>0"
D ^DIC
; capture the division name and number after user selection
S PSBNAME=$$GET1^DIQ(40.8,+Y,.01,"E")
S PSBDPTR=$$GET1^DIQ(40.8,+Y,.07,"I") ; pointer to file #4
S PSBDIV=PSBDPTR
S ^TMP("PSBMMRB",$J)=PSBMUDV_U_PSBDIV_U_PSBNAME
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBMMRB 5570 printed Oct 16, 2024@17:41:08 Page 2
PSBMMRB ;AITC/CR - REPORT FOR RESPIRATORY THERAPY MEDS ;11/29/18 5:37am
+1 ;;3.0;BAR CODE MED ADMIN;**103**;Mar 2004;Build 21
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Reference/ICR #
+5 ; ^DPT("CN"/6984 (private)
+6 ; $$GET1^DIQ/2056 (supported)
+7 ; ^DG(40.8/2817 (controlled)
+8 ; ^DG(43/6812 (private)
+9 ; File #44/10040 (supported)
+10 ; ^VA(200/10060 (supported)
+11 ; %ZTLOAD/10063 (supported)
+12 ; %ZIS/10086 (supported)
+13 ; %ZISC/10089 (supported)
+14 ;
+15 ;=================================================================
EN1 ;
+1 WRITE !!,"Report for Respiratory Therapy Medications",!
+2 NEW D0,DIC,PSBDATA,PSBDPTR,PSBDIV,PSBDVNM,PSBNAME,PSBMUDV,PSBSTIEN,X,Y
+3 KILL ^TMP($JOB),^TMP("PSBMMRB")
+4 SET D0=1
SET PSBMUDV=$SELECT($$GET1^DIQ(43,D0,11,"I")=1:1,1:0)
+5 IF PSBMUDV=1
DO CHK1
DO EN2
QUIT
+6 IF PSBMUDV=0
DO ALL
DO EN2
QUIT
+7 QUIT
+8 ;
EN2 IF $PIECE($GET(^VA(200,DUZ,2,0)),U,4)=0
WRITE !!,$CHAR(7),"You have no valid divisions in the NEW PERSON file."
SET Y="^"
QUIT
+1 IF '$ORDER(^DG(40.8,"AD",DUZ(2),""))
WRITE !!,$CHAR(7),"Your NEW PERSON file division was not found in the MEDICAL CENTER DIVISION file."
SET Y="^"
QUIT
+2 IF Y=""!(Y<0)!(Y="^")
QUIT
+3 SET PSBDIV=$PIECE($GET(^TMP("PSBMMRB",$JOB)),U,2)
+4 SET PSBNAME=$PIECE($GET(^TMP("PSBMMRB",$JOB)),U,3)
+5 WRITE !
+6 SET %DT="AE"
+7 SET %DT("A")="Select date of Respiratory Therapy Meds Report (e.g., T or T-1, etc.): "
+8 DO ^%DT
+9 IF Y'=-1
Begin DoDot:1
+10 SET RDATE=Y
+11 WRITE !!,"Please choose a 132 character printer",!
+12 WRITE "Queuing of this report is recommended",!
+13 SET %ZIS="MQ"
+14 DO ^%ZIS
+15 IF POP
KILL %ZIS
WRITE !,"Device not ready"
QUIT
+16 IF $DATA(IO("Q"))
Begin DoDot:2
+17 SET ZTRTN="EN3^PSBMMRB"
+18 SET ZTSAVE("RDATE")=""
+19 SET ZTSAVE("PSBMUDV")=""
+20 SET ZTSAVE("PSBDIV")=""
+21 SET ZTSAVE("PSBNAME")=""
+22 SET ZTDESC("Respiratory Therapy Meds Report")=""
+23 DO ^%ZTLOAD
End DoDot:2
+24 ; allow user to send report immediately to the screen
+25 IF '$DATA(IO("Q"))
Begin DoDot:2
+26 DO WAIT^DICD
USE IO
DO EN3^PSBMMRB
+27 IF IO'=IO(0)
DO ^%ZISC
End DoDot:2
End DoDot:1
+28 DO ^%ZISC
+29 DO EXIT
+30 QUIT
+31 ;
EN3 ; create new entry; note: national routine PSBO1 is modified for a new report,
+1 ; at NEW+3^PSBO1 add RT code for Respiratory Therapy Meds report
+2 ;
+3 ;for Respiratory Therapy Meds report
DO NEW^PSBO1(.PSBRPT,"RT")
+4 if $PIECE($GET(PSBRPT(0)),U)<1
GOTO EXIT
+5 ; edit new entry.
+6 SET DA=$PIECE($GET(PSBRPT(0)),U)
SET DIE="^PSB(53.69,"
+7 SET DR=".06///^S X=ION;.11///W;.15=///B;.16=///"_RDATE_";.17=///0001;.19=///2400"
+8 LOCK +(^PSB(53.69,DA)):$SELECT($GET(DILOCKTM)>30:DILOCKTM,1:30)
IF '$TEST
GOTO EXIT
+9 DO ^DIE
+10 LOCK -(^PSB(53.69,DA))
+11 ; loop thru ^DPT("CN" and get all wards with patients
+12 ; ZZA is the ward name, ZZB is the IEN for the patient
+13 NEW ZZA,ZZB,WARD
+14 SET ZZA=""
FOR
SET ZZA=$ORDER(^DPT("CN",ZZA))
if ZZA=""
QUIT
Begin DoDot:1
+15 NEW DIVPTR,PSBSTA42,ZZAIEN
+16 SET ZZB=""
FOR
SET ZZB=$ORDER(^DPT("CN",ZZA,ZZB))
if ZZB=""
QUIT
Begin DoDot:2
+17 SET ZZAIEN=$ORDER(^SC("B",ZZA,""))
+18 if +$GET(ZZAIEN)=""
QUIT
+19 ; station # for ward
SET DIVPTR=$$GET1^DIQ(44,ZZAIEN,3.5,"I")
+20 SET PSBSTA42=$$GET1^DIQ(40.8,DIVPTR,.07,"I")
+21 ; capture the ward name
+22 ; ward name
SET WARD=$$GET1^DIQ(44,ZZAIEN,.01,"E")
+23 ; single division only
IF (PSBMUDV=1)&(PSBDIV'=PSBSTA42)
QUIT
+24 SET ^TMP($JOB,WARD)=""
End DoDot:2
End DoDot:1
+25 ;
+26 ; if there are no wards in the division queried, issue a blank report
+27 IF '$DATA(^TMP($JOB))
Begin DoDot:1
+28 SET PSBHDR(1)="RESPIRATORY THERAPY MEDICATIONS from "_$$FMTE^XLFDT(DT)_"@00:01"_" thru "_$$FMTE^XLFDT(DT)_"@24:00"
+29 SET PSBWRD=""
+30 DO WRDHDR^PSBORT
+31 WRITE !,"No Medications Found"
+32 QUIT
End DoDot:1
QUIT
+33 ;
+34 NEW NUM,NURIEN,WARD1,WARD2
+35 ; get only active wards from #211.4
DO NWLIST^PSBRPC(.WARD1,)
+36 SET NUM=0
FOR
SET NUM=$ORDER(WARD1(NUM))
if NUM'>0
QUIT
IF $PIECE($GET(WARD1(NUM)),U,2)["[MAS WARD]"
SET WARD2($PIECE($PIECE($GET(WARD1(NUM)),U,2),"[",1))=$PIECE($GET(WARD1(NUM)),U,1)
+37 ; used in PSBORT to track wards printed
NEW FLAGPRT
+38 SET FLAGPRT=""
+39 SET WARD=""
FOR
SET WARD=$ORDER(^TMP($JOB,WARD))
if WARD=""
QUIT
Begin DoDot:1
+40 NEW SUB
+41 SET SUB=$ORDER(WARD2(WARD))
+42 SET NURIEN=$PIECE($GET(WARD2(SUB)),U)
+43 SET DA=$PIECE($GET(PSBRPT(0)),U)
SET DIE="^PSB(53.69,"
+44 ; don't prompt when finding similar ward names
SET DR=".13////^S X=NURIEN"
+45 LOCK +(^PSB(53.69,DA)):$SELECT($GET(DILOCKTM)>30:DILOCKTM,1:30)
IF '$TEST
GOTO EXIT
+46 DO ^DIE
+47 LOCK -(^PSB(53.69,DA))
+48 DO DQ^PSBO(DA)
End DoDot:1
+49 QUIT
+50 ;
EXIT ; clean up.
+1 KILL DA,DIE,DR,PSBRPT,RDATE
+2 KILL D0,^TMP($JOB),^TMP("PSBMMRB",$JOB)
+3 QUIT
+4 ;
CHK1 ; The user must have at least one division from file #40.8 in his file #200 record.
+1 NEW DIR
+2 WRITE !
+3 SET DIR(0)="SB^A:All Divisions;O:One Division"
+4 SET DIR("?")="Select either All Divisions or One Division."
+5 SET DIR("A")="Do you want (A)ll Divisions or just (O)ne Division"
+6 SET DIR("B")="O"
+7 DO ^DIR
KILL DIR
IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)!$DATA(DIRUT)
QUIT
+8 IF Y=""
QUIT
+9 ; regardless user divisions in file #200
IF Y(0)="One Division"
DO ONE
QUIT
+10 ; for all divisions in a multisite setup
IF Y(0)="All Divisions"
SET PSBMUDV=2
+11 QUIT
+12 ;
ALL ; user gets all divisions
+1 ; all divisions selected
SET Y(0)="All Divisions"
+2 SET PSBDIV=DUZ(2)
+3 ; current IEN for station
SET PSBSTIEN=+$ORDER(^DG(40.8,"AD",DUZ(2),""))
+4 SET Y=$$GET1^DIQ(40.8,PSBSTIEN,.01,"E")
+5 IF '$DATA(Y)
SET Y=DUZ(2)
+6 SET PSBNAME=$$NAME^XUAF4(DUZ(2))
+7 SET PSBMUDV=0
+8 SET ^TMP("PSBMMRB",$JOB)=PSBMUDV_U_PSBDIV_U_PSBNAME
+9 QUIT
+10 ;
ONE ; when user selects one division from many in file #200, look at file #40.8 for a match if available
+1 WRITE !
+2 ; current IEN for station
SET PSBSTIEN=+$ORDER(^DG(40.8,"AD",DUZ(2),""))
+3 ;division name
SET PSBDVNM=$$GET1^DIQ(40.8,PSBSTIEN,.01,"I")
+4 SET DIC("B")=PSBDVNM
+5 SET DIC("A")="Select Division: "
SET DIC="^DG(40.8,"
SET DIC(0)="AEMQ"
SET DIC("S")="I $$SITE^VASITE(,+Y)>0"
+6 DO ^DIC
+7 ; capture the division name and number after user selection
+8 SET PSBNAME=$$GET1^DIQ(40.8,+Y,.01,"E")
+9 ; pointer to file #4
SET PSBDPTR=$$GET1^DIQ(40.8,+Y,.07,"I")
+10 SET PSBDIV=PSBDPTR
+11 SET ^TMP("PSBMMRB",$JOB)=PSBMUDV_U_PSBDIV_U_PSBNAME
+12 QUIT
