ACKQFIL1 ;BIR/PTD - Update A&SP Files per CO Directive - CONTINUED ;20 Jun 2013 10:49 AM
;;3.0;QUASAR;**1,21**;Feb 11, 2000;Build 40
;
; Reference/IA
; $$CSI^ICDEX - 5747
;
;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 ICDFMT=2,^TMP("ACKQ_CO_DIRECTIVE",$J)=""
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
N ACKICDCS S (ACKIEN,DA)=+Y,ACKICDCS=$$CSI^ICDEX(80,+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.
.I ACKICDCS=30 S ACKHRLOS=0 Q
.S ACKHRLOS=$P(^ACK(ACKFNUM,ACKIEN,0),"^",5) S:ACKHRLOS="" ACKHRLOS=0 Q
.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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HACKQFIL1 5149 printed Nov 22, 2024@17:42:14 Page 2
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
+2 ;
+3 ; Reference/IA
+4 ; $$CSI^ICDEX - 5747
+5 ;
+6 ;Variables defined upon entry: ACKFNAM (file name), ACKFNUM (file number).
+7 WRITE !!,"All fields MUST be answered. Otherwise a new entry",!,"is considered incomplete and will be deleted.",!
ADD ;User wants to add new file entries.
+1 SET ICDFMT=2
SET ^TMP("ACKQ_CO_DIRECTIVE",$JOB)=""
+2 SET (DIC,DIE)="^ACK("_ACKFNUM_","
SET DIC(0)="QEALM"
SET DIC("A")="Enter "_$SELECT(ACKFNUM=509850:"Account Number",1:"Code")_": "
SET ACKLAYGO=""
SET DLAYGO=ACKFNUM
DO ^DIC
KILL DIC,ICDFMT,^TMP("ACKQ_CO_DIRECTIVE",$JOB)
IF Y<0
DO EXIT^ACKQFIL
GOTO FILE^ACKQFIL
+3 NEW ACKICDCS
SET (ACKIEN,DA)=+Y
SET ACKICDCS=$$CSI^ICDEX(80,+Y)
+4 IF ACKFNUM="509850.4"
DO LONG^ACKQUTL6(ACKIEN,"1")
+5 SET ACKNEW=$PIECE(Y,"^",3)
LOCK +^ACK(ACKFNUM,ACKIEN):5
IF '$TEST
WRITE !,"Another user is editing this entry...try again later."
DO EXIT^ACKQFIL
GOTO FILE^ACKQFIL
ORIG ; For an existing entry, get the original zero node field values.
+1 if 'ACKNEW
SET ACKORIG=^ACK(ACKFNUM,ACKIEN,0)
CDR IF ACKFNUM=509850
SET DR="1T;2T~d;3T~d;4T~d"
DO ^DIE
KILL DA,DIE,DR
GOTO CHECK
ICD ;Logic falls down to MOD.
IF ACKFNUM=509850.1
SET DR=".04///SA;.06T~d"
DO ^DIE
Begin DoDot:1
+1 IF ACKICDCS=30
SET ACKHRLOS=0
QUIT
+2 SET ACKHRLOS=$PIECE(^ACK(ACKFNUM,ACKIEN,0),"^",5)
if ACKHRLOS=""
SET ACKHRLOS=0
QUIT
+3 KILL DIR,X,Y
SET DIR(0)="Y"
SET DIR("A")="Is this a hearing loss code which requires audiology data"
SET DIR("?")="Enter YES to require audiology questions for this code."
+4 SET DIR("B")=$SELECT($PIECE(^ACK(ACKFNUM,ACKIEN,0),"^",5)=1:"YES",1:"NO")
+5 SET DIR("??")="^D HRLOS^ACKQHLP1"
WRITE !
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
SET ACKHRLOS=+Y
End DoDot:1
if $DATA(DIRUT)
GOTO CHECK
SET DR=".05///^S X=ACKHRLOS"
DO ^DIE
CPT IF ACKFNUM=509850.4
SET DR=".02///SA;.04T~d;.06T"
DO ^DIE
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."
+2 ; I ACKFNUM=509850.1 S DIR("B")=$S($P(^ACK(509850.1,ACKIEN,0),"^",2)=1:"YES",1:"NO")
+3 ; I ACKFNUM=509850.4 S DIR("B")=$S($P(^ACK(509850.4,ACKIEN,0),"^",5)=1:"YES",1:"NO")
+4 ; S DIR("??")="^D MOD^ACKQHLP1" W ! D ^DIR K DIR G:$D(DIRUT) CHECK S ACKMOD=+Y
+5 ; S DR=$S(ACKFNUM=509850.4:".05",1:".02")_"///^S X=ACKMOD" D ^DIE
+6 ; I ACKMOD=0 G CHECK ;Code does not have modifiers.
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
+2 ; S (ACKSUB,DA)=+Y,DR=".01T;.02T"_$S(ACKFNUM=509850.4:";.03T",1:"") D ^DIE K DA,DIE,DR G SUBFL
+3 ;
CHECK ; Determine if all fields have been answered.
+1 ; ACKCOMP equals: 1 if all fields answered.
+2 ; 0 if zero node fields not answered.
+3 ; -1 if subfile fields not answered.
+4 SET ACKZNODE=^ACK(ACKFNUM,ACKIEN,0)
SET ACKCOMP=1
CKCDR ; Examine CDR ACCOUNT file.
+1 IF ACKFNUM=509850
Begin DoDot:1
+2 FOR PC=1:1:5
IF $PIECE(ACKZNODE,"^",PC)=""
SET ACKCOMP=0
DO RESET
End DoDot:1
CKICD ; Examine A&SP DIAGNOSTIC CONDITION file.
+1 IF ACKFNUM=509850.1
Begin DoDot:1
+2 FOR PC=1,4,5,6
IF $PIECE(ACKZNODE,"^",PC)=""
SET ACKCOMP=0
DO RESET
End DoDot:1
+3 ; . 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
+4 ; .. 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.
+1 IF ACKFNUM=509850.4
Begin DoDot:1
+2 FOR PC=1,2,4,6
IF $PIECE(ACKZNODE,"^",PC)=""
SET ACKCOMP=0
DO RESET
End DoDot:1
+3 ; . 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
+4 ; .. 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
+5 ;
+6 ; All fields answered for CDR.
+7 ;
+8 IF (ACKFNUM=509850)&(ACKCOMP=1)
WRITE !!
DO CNTR^ACKQUTL("<<FILE ENTRY IS COMPLETE.>>")
WRITE !
GOTO UNLK
+9 ; New entry requires all fields to be answered, else entry is deleted.
+10 IF (ACKNEW)&(ACKCOMP'=1)
KILL ACKZNODE,ACKSUB,PC
DO DIK
GOTO UNLK
+11 ; Existing entry. Blank fields on zero node restored to original value.
+12 IF ('ACKNEW)&(ACKCOMP=0)
WRITE !!
DO CNTR^ACKQUTL("<<AN EXISTING ENTRY CAN ONLY BE INACTIVATED.>>")
WRITE !
GOTO UNLK
+13 ; Existing entry. Blank fields left in subfile.
+14 IF ('ACKNEW)&(ACKCOMP=-1)
WRITE !!
DO CNTR^ACKQUTL("<<YOU DID NOT ANSWER ALL FIELDS FOR THE MODIFIERS.>>")
WRITE !
DO CNTR^ACKQUTL("<<PLEASE RE-EDIT THIS ENTRY TO PRESERVE DATA INTEGRITY.>>")
WRITE !
GOTO UNLK
+15 ; All fields answered for ICD9 and CPT.
+16 IF ACKCOMP=1
WRITE !!
DO CNTR^ACKQUTL("<<FILE ENTRY IS COMPLETE.>>")
WRITE !
UNLK LOCK -^ACK(ACKFNUM,ACKIEN)
+1 DO KVAR
GOTO ADD
+2 ;
DIK ; All fields not answered for new entry, so delete it.
+1 WRITE !!,$CHAR(7)
DO CNTR^ACKQUTL("<<INCOMPLETE RECORD DELETED!>>")
WRITE !
+2 SET DIK="^ACK("_ACKFNUM_","
SET DA=ACKIEN
DO ^DIK
+3 QUIT
+4 ;
KVAR ; Kill selected variables.
+1 KILL ACKCOMP,ACKHRLOS,ACKLAYGO,ACKMOD,ACKNEW,ACKORIG,ACKZNODE,DA,DIC,DIE,DIK,DIR,DIRUT,DLAYGO,X,Y
+2 QUIT
+3 ;
RESET ; Existing entry edited, leaving blank fields.
+1 ; Restore original value for any blank field on zero node.
+2 IF 'ACKNEW
SET $PIECE(^ACK(ACKFNUM,ACKIEN,0),"^",PC)=$PIECE(ACKORIG,"^",PC)
+3 QUIT
+4 ;
