Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBPU1

IBPU1.m

Go to the documentation of this file. 
  1. IBPU1 ;ALB/CPM - ARCHIVE/PURGING UTILITIES (CON'T.) ; 20-APR-92
  1.  ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
  1.  ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  ;
  1. NODUZ() ; Check for the existence of DUZ
  1.  ;         Input:   NONE
  1.  ;         Output:  0  --  has DUZ,  1  --  no DUZ
  1.  N Y
  1.  I $D(DUZ)[0 S Y=1 W !!,"Your DUZ code must be defined in order to use this option.",!
  1.  Q +$G(Y)
  1.  ;
  1. NOESIG(USER) ; Check Electronic Signature Code
  1.  ;         Input:   USER  --   ien in New Person file
  1.  ;         Output:  0  --  has code,  1  --  no code
  1.  N Y
  1.  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.",!
  1.  Q +$G(Y)
  1.  ;
  1. ESIG(USER) ; Enter Electronic Signature Code
  1.  ;         Input:   USER  --   ien in New Person file
  1.  ;         Output:  0  --  not entered or '^' out,  1  --  entered OK
  1.  N I,J,SIG,X,Y S SIG=$P($G(^VA(200,USER,20)),"^",4),Y=0
  1.  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
  1.  W !,"Your Electronic Signature Code has " W:'Y "not " W "been verified."
  1.  Q Y
  1.  ;
  1. OKAY(JOB) ; Okay to queue this job?
  1.  ;         Input:   JOB  --  1 - Search, 2 - Archive, 3 - Purge
  1.  ;         Output:  0  --  No, not okay,  1  --  Yes, okay to continue
  1.  N DIR,DIRUT,DUOUT,DTOUT,Y
  1.  S DIR(0)="Y",DIR("A")="Is it okay to queue this "_$P("search^archive^purge","^",JOB)
  1.  S DIR("?",1)="Enter:  'Y'  if you wish to task off this job, or"
  1.  S DIR("?")="        'N' or '^'  to quit this option." W ! D ^DIR
  1.  Q $S($D(DIRUT)!($D(DUOUT))!($D(DTOUT)):0,1:Y)
  1.  ;
  1. TASK ; Task off job.
  1.  ;  Input:  IBOP  --  1 - Search, 2 - Archive, 3 - Purge
  1.  ;          IBD(  --  input data
  1.  S ZTRTN="QUE^IBP",ZTDTH=$H,(ZTSAVE("IBD("),ZTSAVE("IBOP"))="",ZTIO=$S(IBOP=2:ION,1:"")
  1.  S ZTDESC=$P("FIND^ARCHIVE^PURGE","^",IBOP)_" BILLING DATA"_$S(IBOP=1:" TO ARCHIVE",1:"")
  1.  D ^%ZTLOAD W !!,$S($D(ZTSK):"This job has been queued.  The task number is "_ZTSK_".",1:"Unable to queue this job.")
  1.  K ZTSK Q
  1.  ;
  1.  ;
  1. DEL(FILE) ; Delete a search template from file #.401 (Sort Templates)
  1.  ;         Input:   FILE  --   file for which template must be deleted
  1.  ;         Output:  None
  1.  N DA,DIK,TMPL
  1.  S DA=$$LOGIEN(FILE)
  1.  S TMPL=$P($G(^IBE(350.6,DA,0)),"^",2)
  1.  I TMPL]"" S DA=$O(^DIBT("B",TMPL,0)) I DA S DIK="^DIBT(" D ^DIK
  1.  Q
  1.  ;
  1. UPD(LOG,FIELD,VALUE) ; Update/Delete Log Entry fields
  1.  ;         Input:   LOG   --  ien of log entry to be updated
  1.  ;                  FIELD --  field number of field being updated
  1.  ;                  VALUE --  value to be stuffed into field
  1.  ;         Output:  NONE
  1.  N DA,DR,DIE
  1.  S DIE="^IBE(350.6,",DA=LOG,DR=FIELD_"///"_VALUE D ^DIE
  1.  Q
  1.  ;
  1. LOGIEN(FILE) ; Find the most current log entry for a file
  1.  ;         Input:   FILE  --   file for which log entry must be deleted
  1.  ;         Output:  ien of most current log entry for a file
  1.  Q +$O(^(+$O(^IBE(350.6,"AF",FILE,"")),0))