source: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVSUS1.m@ 1141

Last change on this file since 1141 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.9 KB
Line 
1PSIVSUS1 ;BIR/RGY-REPRINT LABEL FROM SUSPENSE ;24 JAN 94 / 11:37 AM
2 ;;5.0; INPATIENT MEDICATIONS ;**58**;16 DEC 97
3 ;
4 ; Reference to ^PS(55 is supported by DBIA 2191.
5 ;
6 D ^PSIVXU I $D(XQUIT) K XQUIT Q
7BEG S Y=1,BAT="@",PSIVRPNT=1 F I=1:1 S BAT=$O(^PS(55,"PSIVSUS",PSIVSN,BAT)) Q:BAT="" W !?5,I,") Labels printed on: " S Y=$E(BAT,2,999) X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2) S Y=BAT
8 I Y W !!,"*** There are no labels to reprint ! ***" G Q
9ASK S X="Reprint batch #^"_(I-1)_"^^^QUX=+QUX" D ENQ^PSIV G:"^"[X Q I X["?" S HELP="RNTBAT" D ^PSIVHLP1 G ASK
10 S PSIVDT=+X\1,X="A" F Y=1:1 S X=$O(^PS(55,"PSIVSUS",PSIVSN,X)) Q:X=""!(Y=PSIVDT)
11 I X="" W $C(7)," ???" G ASK
12OV S PSIVDT=X S Y=$E(X,2,999) X ^DD("DD") W " Labels printed on ",$P(Y,"@")," ",$P(Y,"@",2)
13 I PSIVPL'=ION S ZTIO=PSIVPL,ZTDESC="REPRINT LABELS FROM SUSPENSE (IV)",ZTRTN="DQLBL^PSIVSUS1" D QSET G Q
14DQLBL F DFN=0:0 S DFN=$O(^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN)) Q:'DFN D ENIV^PSJAC F ON=0:0 S ON=$O(^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON)) Q:'ON F SDT=0:0 S SDT=$O(^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON,SDT)) Q:'SDT D LA
15Q K BAT,PSIVDOSE,PSIVDT,PSIVNOL,PSIVRPNT,SDT,Z
16Q1 D ENIVKV^PSGSETU S:$D(ZTQUEUED) ZTREQ="@"
17 Q
18LA Q:"PDH"[$P($G(^PS(55,DFN,"IV",ON,0)),"^",17)
19 ;S PSIVNOL=^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON,SDT),PSIVDOSE=$P(PSIVNOL,"^",2),PSIVCT=1,ACTION=1,TRACK=3,P16=$P(PSIVNOL,"^",3),PSIVNOL=+PSIVNOL,P(4)=$P(^PS(55,DFN,"IV",ON,0),"^",4) D ^PSIVLTR D ^PSIVHYPL:P(4)="H",^PSIVLABL:"APSC"[P(4) Q
20 S PSIVNOL=^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON,SDT),PSIVDOSE=$P(PSIVNOL,"^",2),PSIVCT=1,ACTION=1,TRACK=3,P16=$P(PSIVNOL,"^",3),PSIVNOL=+PSIVNOL,P(4)=$P(^PS(55,DFN,"IV",ON,0),"^",4)
21 D ^PSIVLTR
22 S PSIVWMFL=1
23 NEW PSJID,PSIVOID,PSIVID,X,XX
24 F PSJID=0:0 S PSJID=$O(^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON,SDT,PSJID)) Q:'PSJID D REPRT^PSIVLBL1
25 ;
26 ;Kill old ID and set newly reprinted ID.
27 ;
28 F X=0:0 S X=$O(PSIVOID(X)) Q:'X D
29 . K ^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON,SDT,X)
30 F X=0:0 S X=$O(PSIVID(X)) Q:'X D
31 . S ^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON,SDT,X)=""
32 K PSIVWMFL,PSIVOID,PSIVID
33 Q
34ENT ;Will print man. list for suspense
35 D ^PSIVXU I $D(PSIVXU) K PSIVXU Q
36 I PSIVPR'=ION K ZTDTH S ZTIO=PSIVPR,ZTDESC="PRINT MANUFACTURING LIST FOR SUSPENSE (IV)",ZTRTN="DQENT^PSIVSUS1" D QSET G QENT
37DQENT K ^PS(55,"PSIVSUSM",PSIVSN,$J),PSIVOD,PSIVCD,PSIVMT S PSIVGL1="PSIVSUSM",PSIVGL2=$J
38 F DFN=0:0 S DFN=$O(^PS(55,"PSIVSUS",PSIVSN,DFN)) Q:'DFN D ENIV^PSJAC,RGY
39 D ENT^PSIVMAN1
40QENT W:'$D(PSIVPR)&($Y) @IOF K ^PS(55,"PSIVSUSM",PSIVSN,$J),D,DA,DFN,I,JJ,JJ1,ON,P,PSIVGL1,PSIVGL2,PSIVTTM,SDT,TOTAL,VAERR,X,Y,Z,Z1,Z2 D Q1
41 Q
42RGY F ON=0:0 S ON=$O(^PS(55,"PSIVSUS",PSIVSN,DFN,ON)) Q:'ON D SETP I "EOPHD"'[P(17) F SDT=0:0 S SDT=$O(^PS(55,"PSIVSUS",PSIVSN,DFN,ON,SDT)) Q:'SDT S PSIVTTM=+^(SDT) D ENS^PSIVMAN
43 Q
44SETP S Y=$G(^PS(55,DFN,"IV",ON,0)) F X=1:1:23 S P(X)=$P(Y,"^",X)
45 Q
46 ;
47QSET ; Set up for queueing.
48 F X="PSIVSN","PSIVDT","PSIVSITE","PSJSYSW0","PSJSYSP0","PSJSYSU" S:$D(@X) ZTSAVE(X)=""
49 D ^%ZTLOAD W:$D(ZTSK) !,"Queued."
Note: See TracBrowser for help on using the repository browser.