77 lines
4.7 KiB
Mathematica
77 lines
4.7 KiB
Mathematica
ACKQFIL1 ;BIR/PTD-Update A&SP Files per CO Directive - CONTINUED ; 04/24/96 15:08
|
|
;;3.0;QUASAR;**1**;Feb 11, 2000
|
|
;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
|
|
;Variables defined upon entry: ACKFNAM (file name), ACKFNUM (file number).
|
|
W !!,"All fields MUST be answered. Otherwise a new entry",!,"is considered incomplete and will be deleted.",!
|
|
ADD ;User wants to add new file entries.
|
|
S (DIC,DIE)="^ACK("_ACKFNUM_",",DIC(0)="QEALM",DIC("A")="Enter "_$S(ACKFNUM=509850:"Account Number",1:"Code")_": ",ACKLAYGO="",DLAYGO=ACKFNUM D ^DIC K DIC I Y<0 D EXIT^ACKQFIL G FILE^ACKQFIL
|
|
S (ACKIEN,DA)=+Y
|
|
I ACKFNUM="509850.4" D LONG^ACKQUTL6(ACKIEN,"1")
|
|
S ACKNEW=$P(Y,"^",3) L +^ACK(ACKFNUM,ACKIEN):5 I '$T W !,"Another user is editing this entry...try again later." D EXIT^ACKQFIL G FILE^ACKQFIL
|
|
ORIG ; For an existing entry, get the original zero node field values.
|
|
S:'ACKNEW ACKORIG=^ACK(ACKFNUM,ACKIEN,0)
|
|
CDR I ACKFNUM=509850 S DR="1T;2T~d;3T~d;4T~d" D ^DIE K DA,DIE,DR G CHECK
|
|
ICD I ACKFNUM=509850.1 S DR=".04///SA;.06T~d" D ^DIE D G:$D(DIRUT) CHECK S DR=".05///^S X=ACKHRLOS" D ^DIE ;Logic falls down to MOD.
|
|
.K DIR,X,Y S DIR(0)="Y",DIR("A")="Is this a hearing loss code which requires audiology data",DIR("?")="Enter YES to require audiology questions for this code."
|
|
.S DIR("B")=$S($P(^ACK(ACKFNUM,ACKIEN,0),"^",5)=1:"YES",1:"NO")
|
|
.S DIR("??")="^D HRLOS^ACKQHLP1" W ! D ^DIR K DIR Q:$D(DIRUT) S ACKHRLOS=+Y
|
|
CPT I ACKFNUM=509850.4 S DR=".02///SA;.04T~d;.06T" D ^DIE
|
|
MOD ; Does this code have mofifiers?
|
|
; K DIR,X,Y S DIR(0)="Y",DIR("A")="Does this code have modifiers",DIR("?")="Answer YES to add code modifiers; answer NO if there are no modifiers."
|
|
; I ACKFNUM=509850.1 S DIR("B")=$S($P(^ACK(509850.1,ACKIEN,0),"^",2)=1:"YES",1:"NO")
|
|
; I ACKFNUM=509850.4 S DIR("B")=$S($P(^ACK(509850.4,ACKIEN,0),"^",5)=1:"YES",1:"NO")
|
|
; S DIR("??")="^D MOD^ACKQHLP1" W ! D ^DIR K DIR G:$D(DIRUT) CHECK S ACKMOD=+Y
|
|
; S DR=$S(ACKFNUM=509850.4:".05",1:".02")_"///^S X=ACKMOD" D ^DIE
|
|
; I ACKMOD=0 G CHECK ;Code does not have modifiers.
|
|
SUBFL ; Selected code has modifiers, subfile fields must be answered.
|
|
; S (DIC,DIE)="^ACK("_ACKFNUM_","_ACKIEN_",1,",DIC(0)="QEALM",DLAYGO=ACKFNUM,DA(1)=ACKIEN,DIC("P")=$P(^DD(ACKFNUM,1,0),"^",2) D ^DIC K DIC I Y<0 G CHECK
|
|
; S (ACKSUB,DA)=+Y,DR=".01T;.02T"_$S(ACKFNUM=509850.4:";.03T",1:"") D ^DIE K DA,DIE,DR G SUBFL
|
|
;
|
|
CHECK ; Determine if all fields have been answered.
|
|
; ACKCOMP equals: 1 if all fields answered.
|
|
; 0 if zero node fields not answered.
|
|
; -1 if subfile fields not answered.
|
|
S ACKZNODE=^ACK(ACKFNUM,ACKIEN,0),ACKCOMP=1
|
|
CKCDR ; Examine CDR ACCOUNT file.
|
|
I ACKFNUM=509850 D
|
|
.F PC=1:1:5 I $P(ACKZNODE,"^",PC)="" S ACKCOMP=0 D RESET
|
|
CKICD ; Examine A&SP DIAGNOSTIC CONDITION file.
|
|
I ACKFNUM=509850.1 D
|
|
.F PC=1,4,5,6 I $P(ACKZNODE,"^",PC)="" S ACKCOMP=0 D RESET
|
|
; . I $P(^ACK(ACKFNUM,ACKIEN,0),"^",2)=1 D I ($P(^ACK(ACKFNUM,ACKIEN,0),"^",2)=1),('$O(^ACK(ACKFNUM,ACKIEN,1,0))) S ACKCOMP=-1
|
|
; .. S ACKSUB=0 F S ACKSUB=$O(^ACK(ACKFNUM,ACKIEN,1,ACKSUB)) Q:'ACKSUB F PC=1,2 I $P(^ACK(ACKFNUM,ACKIEN,1,ACKSUB,0),"^",PC)="" S ACKCOMP=-1
|
|
CKCPT ; Examine A&SP PROCEDURE CODE file.
|
|
I ACKFNUM=509850.4 D
|
|
.F PC=1,2,4,6 I $P(ACKZNODE,"^",PC)="" S ACKCOMP=0 D RESET
|
|
; . I $P(^ACK(ACKFNUM,ACKIEN,0),"^",5)=1 D I ($P(^ACK(ACKFNUM,ACKIEN,0),"^",5)=1),('$O(^ACK(ACKFNUM,ACKIEN,1,0))) S ACKCOMP=-1
|
|
; .. S ACKSUB=0 F S ACKSUB=$O(^ACK(ACKFNUM,ACKIEN,1,ACKSUB)) Q:'ACKSUB F PC=1,2,3 I $P(^ACK(ACKFNUM,ACKIEN,1,ACKSUB,0),"^",PC)="" S ACKCOMP=-1
|
|
;
|
|
; All fields answered for CDR.
|
|
;
|
|
I (ACKFNUM=509850)&(ACKCOMP=1) W !! D CNTR^ACKQUTL("<<FILE ENTRY IS COMPLETE.>>") W ! G UNLK
|
|
; New entry requires all fields to be answered, else entry is deleted.
|
|
I (ACKNEW)&(ACKCOMP'=1) K ACKZNODE,ACKSUB,PC D DIK G UNLK
|
|
; Existing entry. Blank fields on zero node restored to original value.
|
|
I ('ACKNEW)&(ACKCOMP=0) W !! D CNTR^ACKQUTL("<<AN EXISTING ENTRY CAN ONLY BE INACTIVATED.>>") W ! G UNLK
|
|
; Existing entry. Blank fields left in subfile.
|
|
I ('ACKNEW)&(ACKCOMP=-1) W !! D CNTR^ACKQUTL("<<YOU DID NOT ANSWER ALL FIELDS FOR THE MODIFIERS.>>") W ! D CNTR^ACKQUTL("<<PLEASE RE-EDIT THIS ENTRY TO PRESERVE DATA INTEGRITY.>>") W ! G UNLK
|
|
; All fields answered for ICD9 and CPT.
|
|
I ACKCOMP=1 W !! D CNTR^ACKQUTL("<<FILE ENTRY IS COMPLETE.>>") W !
|
|
UNLK L -^ACK(ACKFNUM,ACKIEN)
|
|
D KVAR G ADD
|
|
;
|
|
DIK ; All fields not answered for new entry, so delete it.
|
|
W !!,$C(7) D CNTR^ACKQUTL("<<INCOMPLETE RECORD DELETED!>>") W !
|
|
S DIK="^ACK("_ACKFNUM_",",DA=ACKIEN D ^DIK
|
|
Q
|
|
;
|
|
KVAR ; Kill selected variables.
|
|
K ACKCOMP,ACKHRLOS,ACKLAYGO,ACKMOD,ACKNEW,ACKORIG,ACKZNODE,DA,DIC,DIE,DIK,DIR,DIRUT,DLAYGO,X,Y
|
|
Q
|
|
;
|
|
RESET ; Existing entry edited, leaving blank fields.
|
|
; Restore original value for any blank field on zero node.
|
|
I 'ACKNEW S $P(^ACK(ACKFNUM,ACKIEN,0),"^",PC)=$P(ACKORIG,"^",PC)
|
|
Q
|
|
;
|