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

ACKQFIL1.m

Go to the documentation of this file. 
  1. ACKQFIL1 ;BIR/PTD - Update A&SP Files per CO Directive - CONTINUED ;20 Jun 2013  10:49 AM
  1.  ;;3.0;QUASAR;**1,21**;Feb 11, 2000;Build 40
  1.  ;
  1.  ; Reference/IA
  1.  ;  $$CSI^ICDEX - 5747
  1.  ;
  1.  ;Variables defined upon entry: ACKFNAM (file name), ACKFNUM (file number).
  1.  W !!,"All fields MUST be answered.  Otherwise a new entry",!,"is considered incomplete and will be deleted.",!
  1. ADD ;User wants to add new file entries.
  1.  S ICDFMT=2,^TMP("ACKQ_CO_DIRECTIVE",$J)=""
  1.  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,ICDFMT,^TMP("ACKQ_CO_DIRECTIVE",$J) I Y<0 D EXIT^ACKQFIL G FILE^ACKQFIL
  1.  N ACKICDCS S (ACKIEN,DA)=+Y,ACKICDCS=$$CSI^ICDEX(80,+Y)
  1.  I ACKFNUM="509850.4" D LONG^ACKQUTL6(ACKIEN,"1")
  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
  1. ORIG ; For an existing entry, get the original zero node field values.
  1.  S:'ACKNEW ACKORIG=^ACK(ACKFNUM,ACKIEN,0)
  1. CDR I ACKFNUM=509850 S DR="1T;2T~d;3T~d;4T~d" D ^DIE K DA,DIE,DR G CHECK
  1. 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.
  1.  .I ACKICDCS=30 S ACKHRLOS=0 Q
  1.  .S ACKHRLOS=$P(^ACK(ACKFNUM,ACKIEN,0),"^",5) S:ACKHRLOS="" ACKHRLOS=0 Q
  1.  .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."
  1.  .S DIR("B")=$S($P(^ACK(ACKFNUM,ACKIEN,0),"^",5)=1:"YES",1:"NO")
  1.  .S DIR("??")="^D HRLOS^ACKQHLP1" W ! D ^DIR K DIR Q:$D(DIRUT)  S ACKHRLOS=+Y
  1. CPT I ACKFNUM=509850.4 S DR=".02///SA;.04T~d;.06T" D ^DIE
  1. MOD ; Does this code have mofifiers?
  1.  ; 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."
  1.  ; I ACKFNUM=509850.1 S DIR("B")=$S($P(^ACK(509850.1,ACKIEN,0),"^",2)=1:"YES",1:"NO")
  1.  ; I ACKFNUM=509850.4 S DIR("B")=$S($P(^ACK(509850.4,ACKIEN,0),"^",5)=1:"YES",1:"NO")
  1.  ; S DIR("??")="^D MOD^ACKQHLP1" W ! D ^DIR K DIR G:$D(DIRUT) CHECK S ACKMOD=+Y
  1.  ; S DR=$S(ACKFNUM=509850.4:".05",1:".02")_"///^S X=ACKMOD" D ^DIE
  1.  ; I ACKMOD=0 G CHECK ;Code does not have modifiers.
  1. SUBFL ; Selected code has modifiers, subfile fields must be answered.
  1.  ; 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
  1.  ; S (ACKSUB,DA)=+Y,DR=".01T;.02T"_$S(ACKFNUM=509850.4:";.03T",1:"") D ^DIE K DA,DIE,DR G SUBFL
  1.  ;
  1. CHECK ;   Determine if all fields have been answered.
  1.  ; ACKCOMP equals: 1 if all fields answered.
  1.  ; 0 if zero node fields not answered.
  1.  ; -1 if subfile fields not answered.
  1.  S ACKZNODE=^ACK(ACKFNUM,ACKIEN,0),ACKCOMP=1
  1. CKCDR ; Examine CDR ACCOUNT file.
  1.  I ACKFNUM=509850 D
  1.  .F PC=1:1:5 I $P(ACKZNODE,"^",PC)="" S ACKCOMP=0 D RESET
  1. CKICD ;  Examine A&SP DIAGNOSTIC CONDITION file.
  1.  I ACKFNUM=509850.1 D
  1.  .F PC=1,4,5,6 I $P(ACKZNODE,"^",PC)="" S ACKCOMP=0 D RESET
  1.  ; . 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
  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
  1. CKCPT ; Examine A&SP PROCEDURE CODE file.
  1.  I ACKFNUM=509850.4 D
  1.  .F PC=1,2,4,6 I $P(ACKZNODE,"^",PC)="" S ACKCOMP=0 D RESET
  1.  ; . 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
  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
  1.  ;
  1.  ; All fields answered for CDR.
  1.  ;
  1.  I (ACKFNUM=509850)&(ACKCOMP=1) W !! D CNTR^ACKQUTL("<<FILE ENTRY IS COMPLETE.>>") W ! G UNLK
  1.  ; New entry requires all fields to be answered, else entry is deleted.
  1.  I (ACKNEW)&(ACKCOMP'=1) K ACKZNODE,ACKSUB,PC D DIK G UNLK
  1.  ; Existing entry. Blank fields on zero node restored to original value.
  1.  I ('ACKNEW)&(ACKCOMP=0) W !! D CNTR^ACKQUTL("<<AN EXISTING ENTRY CAN ONLY BE INACTIVATED.>>") W ! G UNLK
  1.  ; Existing entry. Blank fields left in subfile.
  1.  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
  1.  ; All fields answered for ICD9 and CPT.
  1.  I ACKCOMP=1 W !! D CNTR^ACKQUTL("<<FILE ENTRY IS COMPLETE.>>") W !
  1. UNLK L -^ACK(ACKFNUM,ACKIEN)
  1.  D KVAR G ADD
  1.  ;
  1. DIK ; All fields not answered for new entry, so delete it.
  1.  W !!,$C(7) D CNTR^ACKQUTL("<<INCOMPLETE RECORD DELETED!>>") W !
  1.  S DIK="^ACK("_ACKFNUM_",",DA=ACKIEN D ^DIK
  1.  Q
  1.  ;
  1. KVAR ; Kill selected variables.
  1.  K ACKCOMP,ACKHRLOS,ACKLAYGO,ACKMOD,ACKNEW,ACKORIG,ACKZNODE,DA,DIC,DIE,DIK,DIR,DIRUT,DLAYGO,X,Y
  1.  Q
  1.  ;
  1. RESET ; Existing entry edited, leaving blank fields.
  1.  ; Restore original value for any blank field on zero node.
  1.  I 'ACKNEW S $P(^ACK(ACKFNUM,ACKIEN,0),"^",PC)=$P(ACKORIG,"^",PC)
  1.  Q
  1.  ;