source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBPU1.m@ 1000

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

initial load of WorldVistAEHR

File size: 2.9 KB
Line 
1IBPU1 ;ALB/CPM - ARCHIVE/PURGING UTILITIES (CON'T.) ; 20-APR-92
2 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5NODUZ() ; Check for the existence of DUZ
6 ; Input: NONE
7 ; Output: 0 -- has DUZ, 1 -- no DUZ
8 N Y
9 I $D(DUZ)[0 S Y=1 W !!,"Your DUZ code must be defined in order to use this option.",!
10 Q +$G(Y)
11 ;
12NOESIG(USER) ; Check Electronic Signature Code
13 ; Input: USER -- ien in New Person file
14 ; Output: 0 -- has code, 1 -- no code
15 N Y
16 I $P($G(^VA(200,USER,20)),"^",4)="" S Y=1 W !!,"You must enter your Electronic Signature Code in order to use this option.",!
17 Q +$G(Y)
18 ;
19ESIG(USER) ; Enter Electronic Signature Code
20 ; Input: USER -- ien in New Person file
21 ; Output: 0 -- not entered or '^' out, 1 -- entered OK
22 N I,J,SIG,X,Y S SIG=$P($G(^VA(200,USER,20)),"^",4),Y=0
23 W ! F J=1:1 Q:J=4 W !,"ENTER ELECTRONIC SIGNATURE: " X ^%ZOSF("EOFF") R X:$S($D(DTIME):DTIME,1:60) X ^%ZOSF("EON") Q:'$T!(X="")!($E(X)="^") D HASH^XUSHSHP I X=SIG S Y=1 Q
24 W !,"Your Electronic Signature Code has " W:'Y "not " W "been verified."
25 Q Y
26 ;
27OKAY(JOB) ; Okay to queue this job?
28 ; Input: JOB -- 1 - Search, 2 - Archive, 3 - Purge
29 ; Output: 0 -- No, not okay, 1 -- Yes, okay to continue
30 N DIR,DIRUT,DUOUT,DTOUT,Y
31 S DIR(0)="Y",DIR("A")="Is it okay to queue this "_$P("search^archive^purge","^",JOB)
32 S DIR("?",1)="Enter: 'Y' if you wish to task off this job, or"
33 S DIR("?")=" 'N' or '^' to quit this option." W ! D ^DIR
34 Q $S($D(DIRUT)!($D(DUOUT))!($D(DTOUT)):0,1:Y)
35 ;
36TASK ; Task off job.
37 ; Input: IBOP -- 1 - Search, 2 - Archive, 3 - Purge
38 ; IBD( -- input data
39 S ZTRTN="QUE^IBP",ZTDTH=$H,(ZTSAVE("IBD("),ZTSAVE("IBOP"))="",ZTIO=$S(IBOP=2:ION,1:"")
40 S ZTDESC=$P("FIND^ARCHIVE^PURGE","^",IBOP)_" BILLING DATA"_$S(IBOP=1:" TO ARCHIVE",1:"")
41 D ^%ZTLOAD W !!,$S($D(ZTSK):"This job has been queued. The task number is "_ZTSK_".",1:"Unable to queue this job.")
42 K ZTSK Q
43 ;
44 ;
45DEL(FILE) ; Delete a search template from file #.401 (Sort Templates)
46 ; Input: FILE -- file for which template must be deleted
47 ; Output: None
48 N DA,DIK,TMPL
49 S DA=$$LOGIEN(FILE)
50 S TMPL=$P($G(^IBE(350.6,DA,0)),"^",2)
51 I TMPL]"" S DA=$O(^DIBT("B",TMPL,0)) I DA S DIK="^DIBT(" D ^DIK
52 Q
53 ;
54UPD(LOG,FIELD,VALUE) ; Update/Delete Log Entry fields
55 ; Input: LOG -- ien of log entry to be updated
56 ; FIELD -- field number of field being updated
57 ; VALUE -- value to be stuffed into field
58 ; Output: NONE
59 N DA,DR,DIE
60 S DIE="^IBE(350.6,",DA=LOG,DR=FIELD_"///"_VALUE D ^DIE
61 Q
62 ;
63LOGIEN(FILE) ; Find the most current log entry for a file
64 ; Input: FILE -- file for which log entry must be deleted
65 ; Output: ien of most current log entry for a file
66 Q +$O(^(+$O(^IBE(350.6,"AF",FILE,"")),0))
Note: See TracBrowser for help on using the repository browser.