PSIVLBRP ;BIR/MV - REPRINT LABELS FOR AN ORDER ;15 May 2001 3:29 PM
;;5.0;INPATIENT MEDICATIONS;**58,97,250**;16 DEC 97;Build 6
;
; Reference to ^PS(55 is supported by DBIA 2191.
;
EN(PSJIDLST) ;
I '$D(PSJIDLST) W !,"No labels are available" D PAUSE^VALM1 Q
NEW DIR,PSIVCTD
S PSIVCT=1
W !!,"Count as daily usage" S %=1 D YN^DICN Q:%=-1 S PSIVCTD=$S(%=1:1,1:0)
I PSIVCTD=1 K PSIVCT
S PSJY=$$PROMPT()
Q:PSJY=""
;*PSJ*5*250
N PSJSEL,PSJSEL1,PSJID,PSJSOL,PSJSOLERR,PSJERRLST
S PSJERRLST=""
F PSJSEL=1:1 S PSJSEL1=$P(PSJY,",",PSJSEL) Q:PSJSEL1="" D
. S PSJID=$G(PSJIDLST(PSJSEL1)) Q:PSJID=""
. S PSJIDNO=$P(PSJID,"V",2)
. F PSJSOL=0:0 S PSJSOL=$O(^PS(55,DFN,"IVBCMA",PSJIDNO,"SOL",PSJSOL)) Q:'PSJSOL D
. . I $G(^PS(55,DFN,"IVBCMA",PSJIDNO,"SOL",PSJSOL,0))'=$G(^PS(55,DFN,"IV",+ON,"SOL",PSJSOL,0)) S PSJSOLERR=1,PSJERRLST=PSJERRLST_$S(PSJERRLST="":PSJID,1:", "_PSJID)
I $G(PSJSOLERR) D FULL^VALM1 S DIR("A",1)="Solution on label(s) "_PSJERRLST_" does not match current order." S DIR("A")="Enter RETURN to continue" S DIR(0)="FO" D ^DIR Q
;*END PSJ*5*250
D PRT
Q
PROMPT() ;
W !
S DIR(0)="LOA^1:"_PSJIDLST,DIR("A")="Select from 1 - "_PSJIDLST_" or <RETURN> to select by BCMA ID: " D ^DIR
K DIR
S PSJY=Y
I PSJY="" S DIR(0)="FOA^1:50^S X=$$UP^XLFSTR(X) K:'$D(PSJIDLST(X)) X",DIR("A")="Enter a BCMA ID: " D ^DIR S PSJY=$$UP^XLFSTR(Y)
K DIR
W !!
Q PSJY
DEQIA ;
S PSIVNOL=0
F PSJSEL=1:1 S PSJSEL1=$P(PSJY,",",PSJSEL) Q:PSJSEL1="" S PSIVNOL=PSIVNOL+1
F PSJSEL=1:1 S PSJSEL1=$P(PSJY,",",PSJSEL) Q:PSJSEL1="" D
. S:'PSIVCTD PSIVCT=1
. S PSJID=$G(PSJIDLST(PSJSEL1)) Q:PSJID="" D REPRT(PSJID)
K PSJRPHD
Q
REPRT(PSJID) ;
S PSJNEWID=$$BCMA^PSIVBCID(DFN,ON,$D(PSIVCT),$G(PSIV1),$G(PSIV2),$G(PSIVNOL))
I PSJNEWID="" W !,"Can't get a new BCMA ID. Try again" Q
S PSJIDNO=$P(PSJID,"V",2)
S PSIVBAG=$P($G(^PS(55,DFN,"IVBCMA",PSJIDNO,0)),U,8)
N DA,DR,DIE,DIC
;S DIC(0)="L",DA=Y,DA(1)=DFN,X=PSJNEWID,DIC="^PS(55,"_DA(1)_",""IVBCMA""," D FILE^DICN
K DA,DR,DIE S DIE="^PS(55,"_DFN_",""IVBCMA"",",DA=$P(PSJNEWID,"V",2),DA(1)=DFN D NOW^%DTC
;S DR=".02////"_+ON_";3////"_PSIVCTD_";4////"_$E(%,1,12)_";6////"_PSIVBAG D ^DIE
S DR="6////"_PSIVBAG D ^DIE
K DA,DR,DIE,DIC
S PSJNEWID=$P(PSJNEWID,"V",2)
F PSJAD=0:0 S PSJAD=$O(^PS(55,DFN,"IVBCMA",PSJIDNO,"AD",PSJAD)) Q:'PSJAD D
. S PSJADX=$G(^PS(55,DFN,"IVBCMA",PSJIDNO,"AD",PSJAD,0))
. D UP2^PSIVBCID(DFN,PSJNEWID,PSJAD,PSJADX)
F PSJSOL=0:0 S PSJSOL=$O(^PS(55,DFN,"IVBCMA",PSJIDNO,"SOL",PSJSOL)) Q:'PSJSOL D
. S PSJSOLX=$G(^PS(55,DFN,"IVBCMA",PSJIDNO,"SOL",PSJSOL,0))
. D UP3^PSIVBCID(DFN,PSJNEWID,PSJSOL,PSJSOLX)
K DA,DR,DIE,DIC
S DA=PSJIDNO,DA(1)=DFN,DIE="^PS(55,"_DA(1)_",""IVBCMA"","
S DR="5////RP" D ^DIE
K DA,DR,DIE,DIC
D ^PSIVHYPR:P(4)="H",^PSIVLABR:"APSC"[P(4) S:$D(ZTQUEUED) ZTREQ="@"
;PSJRPHD is defined so ^PSIVLABR won't print the header for sub-labels.
S PSJRPHD=1
;If reprinting from war/man list, store new BCMA ID.
S:$G(PSIVWMFL) PSIVID(PSJNEWID)=""
Q
PRT ;
S IONOFF="",IOP=PSIVPL,%ZIS="NQ" D ^%ZIS G:POP Q I IO=IO(0),($E(IOST)="C") W !!! D DEQIA,Q D HOME^%ZIS Q
D HOME^%ZIS
W ! S ZTDTH=$H,ZTIO=PSIVPL,ZTDESC="REPRINT INDIVIDUAL IV LABELS",ZTRTN="DEQIA^PSIVLBRP" F X="IONOFF","P16","PSIVAC","PSIVSN","PSIVSITE","DFN","ON","PSJSYSW0","PSJSYSU","PSJSYSP0","PSJIDLST(","P(","PSJY","PSIVCTD" S ZTSAVE(X)=""
S:$D(PSIVCT) ZTSAVE("PSIVCT")="" D ^%ZTLOAD W:$D(ZTSK) !,"Queued."
Q
Q ;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVLBRP 3465 printed Nov 22, 2024@17:14:27 Page 2
PSIVLBRP ;BIR/MV - REPRINT LABELS FOR AN ORDER ;15 May 2001 3:29 PM
+1 ;;5.0;INPATIENT MEDICATIONS;**58,97,250**;16 DEC 97;Build 6
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA 2191.
+4 ;
EN(PSJIDLST) ;
+1 IF '$DATA(PSJIDLST)
WRITE !,"No labels are available"
DO PAUSE^VALM1
QUIT
+2 NEW DIR,PSIVCTD
+3 SET PSIVCT=1
+4 WRITE !!,"Count as daily usage"
SET %=1
DO YN^DICN
if %=-1
QUIT
SET PSIVCTD=$SELECT(%=1:1,1:0)
+5 IF PSIVCTD=1
KILL PSIVCT
+6 SET PSJY=$$PROMPT()
+7 if PSJY=""
QUIT
+8 ;*PSJ*5*250
+9 NEW PSJSEL,PSJSEL1,PSJID,PSJSOL,PSJSOLERR,PSJERRLST
+10 SET PSJERRLST=""
+11 FOR PSJSEL=1:1
SET PSJSEL1=$PIECE(PSJY,",",PSJSEL)
if PSJSEL1=""
QUIT
Begin DoDot:1
+12 SET PSJID=$GET(PSJIDLST(PSJSEL1))
if PSJID=""
QUIT
+13 SET PSJIDNO=$PIECE(PSJID,"V",2)
+14 FOR PSJSOL=0:0
SET PSJSOL=$ORDER(^PS(55,DFN,"IVBCMA",PSJIDNO,"SOL",PSJSOL))
if 'PSJSOL
QUIT
Begin DoDot:2
+15 IF $GET(^PS(55,DFN,"IVBCMA",PSJIDNO,"SOL",PSJSOL,0))'=$GET(^PS(55,DFN,"IV",+ON,"SOL",PSJSOL,0))
SET PSJSOLERR=1
SET PSJERRLST=PSJERRLST_$SELECT(PSJERRLST="":PSJID,1:", "_PSJID)
End DoDot:2
End DoDot:1
+16 IF $GET(PSJSOLERR)
DO FULL^VALM1
SET DIR("A",1)="Solution on label(s) "_PSJERRLST_" does not match current order."
SET DIR("A")="Enter RETURN to continue"
SET DIR(0)="FO"
DO ^DIR
QUIT
+17 ;*END PSJ*5*250
+18 DO PRT
+19 QUIT
PROMPT() ;
+1 WRITE !
+2 SET DIR(0)="LOA^1:"_PSJIDLST
SET DIR("A")="Select from 1 - "_PSJIDLST_" or <RETURN> to select by BCMA ID: "
DO ^DIR
+3 KILL DIR
+4 SET PSJY=Y
+5 IF PSJY=""
SET DIR(0)="FOA^1:50^S X=$$UP^XLFSTR(X) K:'$D(PSJIDLST(X)) X"
SET DIR("A")="Enter a BCMA ID: "
DO ^DIR
SET PSJY=$$UP^XLFSTR(Y)
+6 KILL DIR
+7 WRITE !!
+8 QUIT PSJY
DEQIA ;
+1 SET PSIVNOL=0
+2 FOR PSJSEL=1:1
SET PSJSEL1=$PIECE(PSJY,",",PSJSEL)
if PSJSEL1=""
QUIT
SET PSIVNOL=PSIVNOL+1
+3 FOR PSJSEL=1:1
SET PSJSEL1=$PIECE(PSJY,",",PSJSEL)
if PSJSEL1=""
QUIT
Begin DoDot:1
+4 if 'PSIVCTD
SET PSIVCT=1
+5 SET PSJID=$GET(PSJIDLST(PSJSEL1))
if PSJID=""
QUIT
DO REPRT(PSJID)
End DoDot:1
+6 KILL PSJRPHD
+7 QUIT
REPRT(PSJID) ;
+1 SET PSJNEWID=$$BCMA^PSIVBCID(DFN,ON,$DATA(PSIVCT),$GET(PSIV1),$GET(PSIV2),$GET(PSIVNOL))
+2 IF PSJNEWID=""
WRITE !,"Can't get a new BCMA ID. Try again"
QUIT
+3 SET PSJIDNO=$PIECE(PSJID,"V",2)
+4 SET PSIVBAG=$PIECE($GET(^PS(55,DFN,"IVBCMA",PSJIDNO,0)),U,8)
+5 NEW DA,DR,DIE,DIC
+6 ;S DIC(0)="L",DA=Y,DA(1)=DFN,X=PSJNEWID,DIC="^PS(55,"_DA(1)_",""IVBCMA""," D FILE^DICN
+7 KILL DA,DR,DIE
SET DIE="^PS(55,"_DFN_",""IVBCMA"","
SET DA=$PIECE(PSJNEWID,"V",2)
SET DA(1)=DFN
DO NOW^%DTC
+8 ;S DR=".02////"_+ON_";3////"_PSIVCTD_";4////"_$E(%,1,12)_";6////"_PSIVBAG D ^DIE
+9 SET DR="6////"_PSIVBAG
DO ^DIE
+10 KILL DA,DR,DIE,DIC
+11 SET PSJNEWID=$PIECE(PSJNEWID,"V",2)
+12 FOR PSJAD=0:0
SET PSJAD=$ORDER(^PS(55,DFN,"IVBCMA",PSJIDNO,"AD",PSJAD))
if 'PSJAD
QUIT
Begin DoDot:1
+13 SET PSJADX=$GET(^PS(55,DFN,"IVBCMA",PSJIDNO,"AD",PSJAD,0))
+14 DO UP2^PSIVBCID(DFN,PSJNEWID,PSJAD,PSJADX)
End DoDot:1
+15 FOR PSJSOL=0:0
SET PSJSOL=$ORDER(^PS(55,DFN,"IVBCMA",PSJIDNO,"SOL",PSJSOL))
if 'PSJSOL
QUIT
Begin DoDot:1
+16 SET PSJSOLX=$GET(^PS(55,DFN,"IVBCMA",PSJIDNO,"SOL",PSJSOL,0))
+17 DO UP3^PSIVBCID(DFN,PSJNEWID,PSJSOL,PSJSOLX)
End DoDot:1
+18 KILL DA,DR,DIE,DIC
+19 SET DA=PSJIDNO
SET DA(1)=DFN
SET DIE="^PS(55,"_DA(1)_",""IVBCMA"","
+20 SET DR="5////RP"
DO ^DIE
+21 KILL DA,DR,DIE,DIC
+22 if P(4)="H"
DO ^PSIVHYPR
if "APSC"[P(4)
DO ^PSIVLABR
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+23 ;PSJRPHD is defined so ^PSIVLABR won't print the header for sub-labels.
+24 SET PSJRPHD=1
+25 ;If reprinting from war/man list, store new BCMA ID.
+26 if $GET(PSIVWMFL)
SET PSIVID(PSJNEWID)=""
+27 QUIT
PRT ;
+1 SET IONOFF=""
SET IOP=PSIVPL
SET %ZIS="NQ"
DO ^%ZIS
if POP
GOTO Q
IF IO=IO(0)
IF ($EXTRACT(IOST)="C")
WRITE !!!
DO DEQIA
DO Q
DO HOME^%ZIS
QUIT
+2 DO HOME^%ZIS
+3 WRITE !
SET ZTDTH=$HOROLOG
SET ZTIO=PSIVPL
SET ZTDESC="REPRINT INDIVIDUAL IV LABELS"
SET ZTRTN="DEQIA^PSIVLBRP"
FOR X="IONOFF","P16","PSIVAC","PSIVSN","PSIVSITE","DFN","ON","PSJSYSW0","PSJSYSU","PSJSYSP0","PSJIDLST(","P(","PSJY","PSIVCTD"
SET ZTSAVE(X)=""
+4 if $DATA(PSIVCT)
SET ZTSAVE("PSIVCT")=""
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Queued."
+5 QUIT
Q ;
+1 QUIT
