source: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVLBRP.m@ 1147

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

initial load of WorldVistAEHR

File size: 2.7 KB
Line 
1PSIVLBRP ;BIR/MV - REPRINT LABELS FOR AN ORDER ;15 May 2001 3:29 PM
2 ;;5.0; INPATIENT MEDICATIONS ;**58,97**;16 DEC 97
3 ;
4 ; Reference to ^PS(55 is supported by DBIA 2191.
5 ;
6EN(PSJIDLST) ;
7 I '$D(PSJIDLST) W !,"No labels are available" D PAUSE^VALM1 Q
8 NEW DIR,PSIVCTD
9 S PSIVCT=1
10 W !!,"Count as daily usage" S %=1 D YN^DICN Q:%=-1 S PSIVCTD=$S(%=1:1,1:0)
11 I PSIVCTD=1 K PSIVCT
12 S PSJY=$$PROMPT()
13 Q:PSJY=""
14 D PRT
15 Q
16PROMPT() ;
17 W !
18 S DIR(0)="LOA^1:"_PSJIDLST,DIR("A")="Select from 1 - "_PSJIDLST_" or <RETURN> to select by BCMA ID: " D ^DIR
19 K DIR
20 S PSJY=Y
21 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)
22 K DIR
23 W !!
24 Q PSJY
25DEQIA ;
26 S PSIVNOL=0
27 F PSJSEL=1:1 S PSJSEL1=$P(PSJY,",",PSJSEL) Q:PSJSEL1="" S PSIVNOL=PSIVNOL+1
28 F PSJSEL=1:1 S PSJSEL1=$P(PSJY,",",PSJSEL) Q:PSJSEL1="" D
29 . S:'PSIVCTD PSIVCT=1
30 . S PSJID=$G(PSJIDLST(PSJSEL1)) Q:PSJID="" D REPRT(PSJID)
31 K PSJRPHD
32 Q
33REPRT(PSJID) ;
34 S PSJNEWID=$$BCMA^PSIVBCID(DFN,ON,$D(PSIVCT),$G(PSIV1),$G(PSIV2),$G(PSIVNOL))
35 I PSJNEWID="" W !,"Can't get a new BCMA ID. Try again" Q
36 S PSJIDNO=$P(PSJID,"V",2)
37 S PSIVBAG=$P($G(^PS(55,DFN,"IVBCMA",PSJIDNO,0)),U,8)
38 N DA,DR,DIE,DIC
39 ;S DIC(0)="L",DA=Y,DA(1)=DFN,X=PSJNEWID,DIC="^PS(55,"_DA(1)_",""IVBCMA""," D FILE^DICN
40 K DA,DR,DIE S DIE="^PS(55,"_DFN_",""IVBCMA"",",DA=$P(PSJNEWID,"V",2),DA(1)=DFN D NOW^%DTC
41 ;S DR=".02////"_+ON_";3////"_PSIVCTD_";4////"_$E(%,1,12)_";6////"_PSIVBAG D ^DIE
42 S DR="6////"_PSIVBAG D ^DIE
43 K DA,DR,DIE,DIC
44 S PSJNEWID=$P(PSJNEWID,"V",2)
45 F PSJAD=0:0 S PSJAD=$O(^PS(55,DFN,"IVBCMA",PSJIDNO,"AD",PSJAD)) Q:'PSJAD D
46 . S PSJADX=$G(^PS(55,DFN,"IVBCMA",PSJIDNO,"AD",PSJAD,0))
47 . D UP2^PSIVBCID(DFN,PSJNEWID,PSJAD,PSJADX)
48 F PSJSOL=0:0 S PSJSOL=$O(^PS(55,DFN,"IVBCMA",PSJIDNO,"SOL",PSJSOL)) Q:'PSJSOL D
49 . S PSJSOLX=$G(^PS(55,DFN,"IVBCMA",PSJIDNO,"SOL",PSJSOL,0))
50 . D UP3^PSIVBCID(DFN,PSJNEWID,PSJSOL,PSJSOLX)
51 K DA,DR,DIE,DIC
52 S DA=PSJIDNO,DA(1)=DFN,DIE="^PS(55,"_DA(1)_",""IVBCMA"","
53 S DR="5////RP" D ^DIE
54 K DA,DR,DIE,DIC
55 D ^PSIVHYPR:P(4)="H",^PSIVLABR:"APSC"[P(4) S:$D(ZTQUEUED) ZTREQ="@"
56 ;PSJRPHD is defined so ^PSIVLABR won't print the header for sub-labels.
57 S PSJRPHD=1
58 ;If reprinting from war/man list, store new BCMA ID.
59 S:$G(PSIVWMFL) PSIVID(PSJNEWID)=""
60 Q
61PRT ;
62 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
63 D HOME^%ZIS
64 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)=""
65 S:$D(PSIVCT) ZTSAVE("PSIVCT")="" D ^%ZTLOAD W:$D(ZTSK) !,"Queued."
66 Q
67Q ;
68 Q
Note: See TracBrowser for help on using the repository browser.