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