IBPU1.m

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))

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))