ABSPOSD3 ; IHS/SD/RLT - DIAGNOSIS CODE ; [ 06/21/2007 11:10 AM ]
;;1.0;PHARMACY POINT OF SALE;**23,48**;JUN 21, 2007;Build 38
Q
; EDIT is called from the menu in ABSPOSO1,
; typically reached from the pharmacy package's call
; to OVERRIDE^ABSPOSO
;
; This routine is responsible for prompting and retaining
; the repeating DIGANOSIS CODES in the CLINICAL segment.
;
EDIT(DIAGIEN) ;EP called from ABSPOSO1 (menu option)
;**Don't believe this is needed for DIAGNOSIS CODE.
;**Left code from DUR just in case.
; Make sure the entry exists in the subfile.
; Create an empty one if necessary.
;
N DIE,DA,DR,DIDEL,DTOUT
S DA=DIAGIEN
S DIE=9002313.491
S DR=1
D ^DIE
;
Q
;
NEW() ;EP - from ABSPOSII create new entry in 9002313.491
F Q:$$FLOCK Q:'$$IMPOSS^ABSPOSUE("L","RTI","interlock on new DIAG rec create",,"NEW",$T(+0))
;
N FLAGS,FDA,IEN,MSG,FN,X,NEWREC
S FN=9002313.491
D NEW1^ABSPOSO2
D FUNLOCK
;
Q NEWREC
;
;
CHKDIAG(DIAGIEN) ;EP from ABSPOSII
;last step - delete if nothing entered
;
N SUBR,FNDREC,CHKR
;
S SUBR=0 ;starting point for review
S FNDREC=1 ;assume we need to delete-reset if we find values
F S SUBR=$O(^ABSP(9002313.491,DIAGIEN,1,SUBR)) Q:'+SUBR D
. ;S CHKR=$TR($P($G(^ABSP(9002313.491,DIAGIEN,1,SUBR,0)),U,2,3),"^")
. S CHKR=$P($G(^ABSP(9002313.491,DIAGIEN,1,SUBR,0)),U,3)
. S:CHKR'="" FNDREC=0
. D:CHKR="" DELSUB(DIAGIEN,SUBR)
;
I FNDREC D
. D DELREC(DIAGIEN)
. S DIAGIEN=""
;
Q DIAGIEN
;
DELSUB(DLIEN,DLSUB) ; delete subrecord - no valid information
;
N FDA,MSG
;
S FDA(9002313.4911,DLSUB_","_DLIEN_",",.01)="@"
DE3 D FILE^DIE("E","FDA","MSG") ;delete the record
I $D(MSG) D LOG^ABSPOSL2("DE3^ABSPOSD3",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
Q:'$D(MSG) ;successful deletion
;
; delete unsuccessful
K ^TMP("ABSP",$J,"ABSPOSD3",$J,"DELSUB")
S ^TMP("ABSP",$J,"ABSPOSD3",$J,"DELSUB")=$$ERRHDR
D ZWRITE^ABSPOS("IEN","FDA","MSG")
G DE3:$$IMPOSS^ABSPOSUE("FM","TR1",,,"DELSUB",$T(+0))
Q
;
DELREC(DLIEN) ;delete record - no valid information
;
N FDA,MSG
;
S FDA(9002313.491,DLIEN_",",.01)="@"
DEL3 D FILE^DIE("E","FDA","MSG") ;delete the record
I $D(MSG) D LOG^ABSPOSL2("DEL3^ABSPOSD3",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
Q:'$D(MSG) ;successful deletion
;
; delete unsuccessful
K ^TMP("ABSP",$J,"ABSPOSD3",$J,"DELREC")
S ^TMP("ABSP",$J,"ABSPOSD3",$J,"DELREC")=$$ERRHDR
D ZWRITE^ABSPOS("IEN","FDA","MSG")
G DEL3:$$IMPOSS^ABSPOSUE("FM","TR1",,,"DELREC",$T(+0))
Q
;
NEWSUB(DIAGIEN) ;EP FROM ABSPOSII
; establish blank lines for new DIAG override entries
; on NEW POS claims (from page 20 on ABSP DATA INPUT)
;(block ABSP INPUT 5.1 DIAG INPUT)
;
N REC,LASTREC,CNT,FDA,RECNUM,REP,SAVNUM,ZERR ; /IHS/OIT/RAM ; 12 JUN 17 ; ADD DBS CALL ERROR RETURN VARIABLE
S (CNT,LASTREC,SAVNUM,REC)=0
;
F S REC=$O(^ABSP(9002313.491,DIAGIEN,1,REC)) Q:'+REC D
. S SAVNUM=$P($G(^ABSP(9002313.491,DIAGIEN,1,REC,0)),"^")
. S:SAVNUM>LASTREC LASTREC=SAVNUM
. S CNT=CNT+1
;
S:LASTREC>91 LASTREC=55 ;rec # lmt 99- 55 is random
S ENDCNT=9-CNT ;tie to the rep num on screen blk
;
F REP=1:1:ENDCNT D
. S RECNUM=LASTREC+REP
. N FDA,IEN,ZERR ; /IHS/OIT/RAM ; 12 JUN 17 ; ADD DBS CALL ERROR RETURN VARIABLE
. S FDA(9002313.4911,"+1,"_DIAGIEN_",",.01)=RECNUM
. D UPDATE^DIE("E","FDA","IEN","ZERR") ; /IHS/OIT/RAM ; 12 JUN 17 ; UPDATE DBS CALL TO ALLOW FOR ERROR RETURN.
. I $D(ZERR) D LOG^ABSPOSL2("NEWSUB^ABSPOSD3",.ZERR) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
;
Q
;
FLOCK() L +^ABSP(9002313.491):300 Q $T
FUNLOCK L -^ABSP(9002313.491) Q
ERRHDR() Q "ERROR AT $H="_$H_" FOR $J="_$J
ABSPOSD3 ; IHS/SD/RLT - DIAGNOSIS CODE ; [ 06/21/2007 11:10 AM ]
+1 ;;1.0;PHARMACY POINT OF SALE;**23,48**;JUN 21, 2007;Build 38
+2 QUIT
+3 ; EDIT is called from the menu in ABSPOSO1,
+4 ; typically reached from the pharmacy package's call
+5 ; to OVERRIDE^ABSPOSO
+6 ;
+7 ; This routine is responsible for prompting and retaining
+8 ; the repeating DIGANOSIS CODES in the CLINICAL segment.
+9 ;
EDIT(DIAGIEN) ;EP called from ABSPOSO1 (menu option)
+1 ;**Don't believe this is needed for DIAGNOSIS CODE.
+2 ;**Left code from DUR just in case.
+3 ; Make sure the entry exists in the subfile.
+4 ; Create an empty one if necessary.
+5 ;
+6 NEW DIE,DA,DR,DIDEL,DTOUT
+7 SET DA=DIAGIEN
+8 SET DIE=9002313.491
+9 SET DR=1
+10 DO ^DIE
+11 ;
+12 QUIT
+13 ;
NEW() ;EP - from ABSPOSII create new entry in 9002313.491
+1 FOR
IF $$FLOCK
QUIT
IF '$$IMPOSS^ABSPOSUE("L","RTI","interlock on new DIAG rec create",,"NEW",$TEXT(+0))
QUIT
+2 ;
+3 NEW FLAGS,FDA,IEN,MSG,FN,X,NEWREC
+4 SET FN=9002313.491
+5 DO NEW1^ABSPOSO2
+6 DO FUNLOCK
+7 ;
+8 QUIT NEWREC
+9 ;
+10 ;
CHKDIAG(DIAGIEN) ;EP from ABSPOSII
+1 ;last step - delete if nothing entered
+2 ;
+3 NEW SUBR,FNDREC,CHKR
+4 ;
+5 ;starting point for review
SET SUBR=0
+6 ;assume we need to delete-reset if we find values
SET FNDREC=1
+7 FOR
SET SUBR=$ORDER(^ABSP(9002313.491,DIAGIEN,1,SUBR))
IF '+SUBR
QUIT
Begin DoDot:1
+8 ;S CHKR=$TR($P($G(^ABSP(9002313.491,DIAGIEN,1,SUBR,0)),U,2,3),"^")
+9 SET CHKR=$PIECE($GET(^ABSP(9002313.491,DIAGIEN,1,SUBR,0)),U,3)
+10 IF CHKR'=""
SET FNDREC=0
+11 IF CHKR=""
DO DELSUB(DIAGIEN,SUBR)
End DoDot:1
+12 ;
+13 IF FNDREC
Begin DoDot:1
+14 DO DELREC(DIAGIEN)
+15 SET DIAGIEN=""
End DoDot:1
+16 ;
+17 QUIT DIAGIEN
+18 ;
DELSUB(DLIEN,DLSUB) ; delete subrecord - no valid information
+1 ;
+2 NEW FDA,MSG
+3 ;
+4 SET FDA(9002313.4911,DLSUB_","_DLIEN_",",.01)="@"
DE3 ;delete the record
DO FILE^DIE("E","FDA","MSG")
+1 ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
IF $DATA(MSG)
DO LOG^ABSPOSL2("DE3^ABSPOSD3",.MSG)
+2 ;successful deletion
IF '$DATA(MSG)
QUIT
+3 ;
+4 ; delete unsuccessful
+5 KILL ^TMP("ABSP",$JOB,"ABSPOSD3",$JOB,"DELSUB")
+6 SET ^TMP("ABSP",$JOB,"ABSPOSD3",$JOB,"DELSUB")=$$ERRHDR
+7 DO ZWRITE^ABSPOS("IEN","FDA","MSG")
+8 IF $$IMPOSS^ABSPOSUE("FM","TR1",,,"DELSUB",$TEXT(+0))
GOTO DE3
+9 QUIT
+10 ;
DELREC(DLIEN) ;delete record - no valid information
+1 ;
+2 NEW FDA,MSG
+3 ;
+4 SET FDA(9002313.491,DLIEN_",",.01)="@"
DEL3 ;delete the record
DO FILE^DIE("E","FDA","MSG")
+1 ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
IF $DATA(MSG)
DO LOG^ABSPOSL2("DEL3^ABSPOSD3",.MSG)
+2 ;successful deletion
IF '$DATA(MSG)
QUIT
+3 ;
+4 ; delete unsuccessful
+5 KILL ^TMP("ABSP",$JOB,"ABSPOSD3",$JOB,"DELREC")
+6 SET ^TMP("ABSP",$JOB,"ABSPOSD3",$JOB,"DELREC")=$$ERRHDR
+7 DO ZWRITE^ABSPOS("IEN","FDA","MSG")
+8 IF $$IMPOSS^ABSPOSUE("FM","TR1",,,"DELREC",$TEXT(+0))
GOTO DEL3
+9 QUIT
+10 ;
NEWSUB(DIAGIEN) ;EP FROM ABSPOSII
+1 ; establish blank lines for new DIAG override entries
+2 ; on NEW POS claims (from page 20 on ABSP DATA INPUT)
+3 ;(block ABSP INPUT 5.1 DIAG INPUT)
+4 ;
+5 ; /IHS/OIT/RAM ; 12 JUN 17 ; ADD DBS CALL ERROR RETURN VARIABLE
NEW REC,LASTREC,CNT,FDA,RECNUM,REP,SAVNUM,ZERR
+6 SET (CNT,LASTREC,SAVNUM,REC)=0
+7 ;
+8 FOR
SET REC=$ORDER(^ABSP(9002313.491,DIAGIEN,1,REC))
IF '+REC
QUIT
Begin DoDot:1
+9 SET SAVNUM=$PIECE($GET(^ABSP(9002313.491,DIAGIEN,1,REC,0)),"^")
+10 IF SAVNUM>LASTREC
SET LASTREC=SAVNUM
+11 SET CNT=CNT+1
End DoDot:1
+12 ;
+13 ;rec # lmt 99- 55 is random
IF LASTREC>91
SET LASTREC=55
+14 ;tie to the rep num on screen blk
SET ENDCNT=9-CNT
+15 ;
+16 FOR REP=1:1:ENDCNT
Begin DoDot:1
+17 SET RECNUM=LASTREC+REP
+18 ; /IHS/OIT/RAM ; 12 JUN 17 ; ADD DBS CALL ERROR RETURN VARIABLE
NEW FDA,IEN,ZERR
+19 SET FDA(9002313.4911,"+1,"_DIAGIEN_",",.01)=RECNUM
+20 ; /IHS/OIT/RAM ; 12 JUN 17 ; UPDATE DBS CALL TO ALLOW FOR ERROR RETURN.
DO UPDATE^DIE("E","FDA","IEN","ZERR")
+21 ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
IF $DATA(ZERR)
DO LOG^ABSPOSL2("NEWSUB^ABSPOSD3",.ZERR)
End DoDot:1
+22 ;
+23 QUIT
+24 ;
FLOCK() LOCK +^ABSP(9002313.491):300
QUIT $TEST
FUNLOCK LOCK -^ABSP(9002313.491)
QUIT
ERRHDR() QUIT "ERROR AT $H="_$HOROLOG_" FOR $J="_$JOB
