source: WorldVistAEHR/trunk/r/QUASAR-ACKQ/ACKQFIL1.m@ 1800

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

initial load of WorldVistAEHR
File size: 4.7 KB
RevLine 
[613]1ACKQFIL1 ;BIR/PTD-Update A&SP Files per CO Directive - CONTINUED ; 04/24/96 15:08
2 ;;3.0;QUASAR;**1**;Feb 11, 2000
3 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
4 ;Variables defined upon entry: ACKFNAM (file name), ACKFNUM (file number).
5 W !!,"All fields MUST be answered. Otherwise a new entry",!,"is considered incomplete and will be deleted.",!
6ADD ;User wants to add new file entries.
7 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
8 S (ACKIEN,DA)=+Y
9 I ACKFNUM="509850.4" D LONG^ACKQUTL6(ACKIEN,"1")
10 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
11ORIG ; For an existing entry, get the original zero node field values.
12 S:'ACKNEW ACKORIG=^ACK(ACKFNUM,ACKIEN,0)
13CDR I ACKFNUM=509850 S DR="1T;2T~d;3T~d;4T~d" D ^DIE K DA,DIE,DR G CHECK
14ICD 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.
15 .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."
16 .S DIR("B")=$S($P(^ACK(ACKFNUM,ACKIEN,0),"^",5)=1:"YES",1:"NO")
17 .S DIR("??")="^D HRLOS^ACKQHLP1" W ! D ^DIR K DIR Q:$D(DIRUT) S ACKHRLOS=+Y
18CPT I ACKFNUM=509850.4 S DR=".02///SA;.04T~d;.06T" D ^DIE
19MOD ; Does this code have mofifiers?
20 ; 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."
21 ; I ACKFNUM=509850.1 S DIR("B")=$S($P(^ACK(509850.1,ACKIEN,0),"^",2)=1:"YES",1:"NO")
22 ; I ACKFNUM=509850.4 S DIR("B")=$S($P(^ACK(509850.4,ACKIEN,0),"^",5)=1:"YES",1:"NO")
23 ; S DIR("??")="^D MOD^ACKQHLP1" W ! D ^DIR K DIR G:$D(DIRUT) CHECK S ACKMOD=+Y
24 ; S DR=$S(ACKFNUM=509850.4:".05",1:".02")_"///^S X=ACKMOD" D ^DIE
25 ; I ACKMOD=0 G CHECK ;Code does not have modifiers.
26SUBFL ; Selected code has modifiers, subfile fields must be answered.
27 ; 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
28 ; S (ACKSUB,DA)=+Y,DR=".01T;.02T"_$S(ACKFNUM=509850.4:";.03T",1:"") D ^DIE K DA,DIE,DR G SUBFL
29 ;
30CHECK ; Determine if all fields have been answered.
31 ; ACKCOMP equals: 1 if all fields answered.
32 ; 0 if zero node fields not answered.
33 ; -1 if subfile fields not answered.
34 S ACKZNODE=^ACK(ACKFNUM,ACKIEN,0),ACKCOMP=1
35CKCDR ; Examine CDR ACCOUNT file.
36 I ACKFNUM=509850 D
37 .F PC=1:1:5 I $P(ACKZNODE,"^",PC)="" S ACKCOMP=0 D RESET
38CKICD ; Examine A&SP DIAGNOSTIC CONDITION file.
39 I ACKFNUM=509850.1 D
40 .F PC=1,4,5,6 I $P(ACKZNODE,"^",PC)="" S ACKCOMP=0 D RESET
41 ; . 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
42 ; .. 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
43CKCPT ; Examine A&SP PROCEDURE CODE file.
44 I ACKFNUM=509850.4 D
45 .F PC=1,2,4,6 I $P(ACKZNODE,"^",PC)="" S ACKCOMP=0 D RESET
46 ; . 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
47 ; .. 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
48 ;
49 ; All fields answered for CDR.
50 ;
51 I (ACKFNUM=509850)&(ACKCOMP=1) W !! D CNTR^ACKQUTL("<<FILE ENTRY IS COMPLETE.>>") W ! G UNLK
52 ; New entry requires all fields to be answered, else entry is deleted.
53 I (ACKNEW)&(ACKCOMP'=1) K ACKZNODE,ACKSUB,PC D DIK G UNLK
54 ; Existing entry. Blank fields on zero node restored to original value.
55 I ('ACKNEW)&(ACKCOMP=0) W !! D CNTR^ACKQUTL("<<AN EXISTING ENTRY CAN ONLY BE INACTIVATED.>>") W ! G UNLK
56 ; Existing entry. Blank fields left in subfile.
57 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
58 ; All fields answered for ICD9 and CPT.
59 I ACKCOMP=1 W !! D CNTR^ACKQUTL("<<FILE ENTRY IS COMPLETE.>>") W !
60UNLK L -^ACK(ACKFNUM,ACKIEN)
61 D KVAR G ADD
62 ;
63DIK ; All fields not answered for new entry, so delete it.
64 W !!,$C(7) D CNTR^ACKQUTL("<<INCOMPLETE RECORD DELETED!>>") W !
65 S DIK="^ACK("_ACKFNUM_",",DA=ACKIEN D ^DIK
66 Q
67 ;
68KVAR ; Kill selected variables.
69 K ACKCOMP,ACKHRLOS,ACKLAYGO,ACKMOD,ACKNEW,ACKORIG,ACKZNODE,DA,DIC,DIE,DIK,DIR,DIRUT,DLAYGO,X,Y
70 Q
71 ;
72RESET ; Existing entry edited, leaving blank fields.
73 ; Restore original value for any blank field on zero node.
74 I 'ACKNEW S $P(^ACK(ACKFNUM,ACKIEN,0),"^",PC)=$P(ACKORIG,"^",PC)
75 Q
76 ;
Note: See TracBrowser for help on using the repository browser.