ABSPOSD2 ; IHS/FCS/DRS - NCPDP DUR overrides ; [ 09/03/2002 11:10 AM ]
;;1.0;PHARMACY POINT OF SALE;**6,48**;JUN 21, 2001;Build 38
Q
; EDIT is called from the menu in ABSPOSO1,
; typically reached from the pharmacy package's call
; to OVERRIDE^ABSPOSO
; GET511 is called from ABSPOSCD during claim construction
;
; This routine will be responsible for prompting for
; and retaining the now repeating DUR segment values
; for the NCPDP 5.1 format.
;
EDIT(DURIEN) ;EP called from ABSPOSO1 (menu option)
;
; Make sure the entry exists in the subfile.
; Create an empty one if necessary.
;
N DIE,DA,DR,DIDEL,DTOUT
S DA=DURIEN
S DIE=9002313.473
S DR=1
D ^DIE
;
;
Q
;
;
NEW() ;EP - create new entry in 9002313.473
F Q:$$FLOCK Q:'$$IMPOSS^ABSPOSUE("L","RTI","interlock on new DUR rec create",,"NEW",$T(+0))
;
N FLAGS,FDA,IEN,MSG,FN,X,NEWREC
S FN=9002313.473
D NEW1^ABSPOSO2
D FUNLOCK
;
Q NEWREC
;
;
CHKDUR(DURIEN) ;EP this should be the last step - we
; need to check the DUR entry, if nothing was input
; let's get rid of it.
;
N SUBR,FNDREC
;
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.473,DURIEN,1,SUBR)) Q:'+SUBR D
. N CHKR
. S CHKR=""
. S CHKR=$TR($P($G(^ABSP(9002313.473,DURIEN,1,SUBR,0)),U,2,7),"^")
. S:CHKR'="" FNDREC=0
. D:CHKR="" DELSUB(DURIEN,SUBR)
;
I FNDREC D
. D DELREC(DURIEN)
. S DURIEN=""
;
Q DURIEN
;
DELSUB(DLIEN,DLSUB) ; delete subrecord - no valid information
;
N FDA,MSG
;
S FDA(9002313.4731,DLSUB_","_DLIEN_",",.01)="@"
DE3 D FILE^DIE("E","FDA","MSG") ;delete the record
Q:'$D(MSG) ;successful deletion
I $D(MSG) D LOG^ABSPOSL2("DE3^ABSPOSD2",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
;
; delete unsuccessful
K ^TMP("ABSP",$J,"ABSPOSD2",$J,"DELSUB")
S ^TMP("ABSP",$J,"ABSPOSD2",$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.473,DLIEN_",",.01)="@"
DEL3 D FILE^DIE("E","FDA","MSG") ;delete the record
Q:'$D(MSG) ;successful deletion
I $D(MSG) D LOG^ABSPOSL2("DEL3^ABSPOSD2",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
;
; delete unsuccessful
K ^TMP("ABSP",$J,"ABSPOSD2",$J,"DELREC")
S ^TMP("ABSP",$J,"ABSPOSD2",$J,"DELREC")=$$ERRHDR
D ZWRITE^ABSPOS("IEN","FDA","MSG")
G DEL3:$$IMPOSS^ABSPOSUE("FM","TR1",,,"DELREC",$T(+0))
Q
;
NEWSUB(DURIEN) ;EP FROM ABSPOSIH
; establish blank lines for new DUR override entries
; on NEW POS claims (from page 20 on ABSP DATA INPUT)
;(block ABSP INPUT 5.1 DUR 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.473,DURIEN,1,REC)) Q:'+REC D
. S SAVNUM=$P($G(^ABSP(9002313.473,DURIEN,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.4731,"+1,"_DURIEN_",",.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^ABSPOSD2",.ZERR) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
;
;
Q
;
FLOCK() L +^ABSP(9002313.473):300 Q $T
FUNLOCK L -^ABSP(9002313.473) Q
ERRHDR() Q "ERROR AT $H="_$H_" FOR $J="_$J
ABSPOSD2 ; IHS/FCS/DRS - NCPDP DUR overrides ; [ 09/03/2002 11:10 AM ]
+1 ;;1.0;PHARMACY POINT OF SALE;**6,48**;JUN 21, 2001;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 ; GET511 is called from ABSPOSCD during claim construction
+7 ;
+8 ; This routine will be responsible for prompting for
+9 ; and retaining the now repeating DUR segment values
+10 ; for the NCPDP 5.1 format.
+11 ;
EDIT(DURIEN) ;EP called from ABSPOSO1 (menu option)
+1 ;
+2 ; Make sure the entry exists in the subfile.
+3 ; Create an empty one if necessary.
+4 ;
+5 NEW DIE,DA,DR,DIDEL,DTOUT
+6 SET DA=DURIEN
+7 SET DIE=9002313.473
+8 SET DR=1
+9 DO ^DIE
+10 ;
+11 ;
+12 QUIT
+13 ;
+14 ;
NEW() ;EP - create new entry in 9002313.473
+1 FOR
IF $$FLOCK
QUIT
IF '$$IMPOSS^ABSPOSUE("L","RTI","interlock on new DUR rec create",,"NEW",$TEXT(+0))
QUIT
+2 ;
+3 NEW FLAGS,FDA,IEN,MSG,FN,X,NEWREC
+4 SET FN=9002313.473
+5 DO NEW1^ABSPOSO2
+6 DO FUNLOCK
+7 ;
+8 QUIT NEWREC
+9 ;
+10 ;
CHKDUR(DURIEN) ;EP this should be the last step - we
+1 ; need to check the DUR entry, if nothing was input
+2 ; let's get rid of it.
+3 ;
+4 NEW SUBR,FNDREC
+5 ;
+6 ;starting point for review
SET SUBR=0
+7 ;assume we need to delete-reset if we find values
SET FNDREC=1
+8 FOR
SET SUBR=$ORDER(^ABSP(9002313.473,DURIEN,1,SUBR))
IF '+SUBR
QUIT
Begin DoDot:1
+9 NEW CHKR
+10 SET CHKR=""
+11 SET CHKR=$TRANSLATE($PIECE($GET(^ABSP(9002313.473,DURIEN,1,SUBR,0)),U,2,7),"^")
+12 IF CHKR'=""
SET FNDREC=0
+13 IF CHKR=""
DO DELSUB(DURIEN,SUBR)
End DoDot:1
+14 ;
+15 IF FNDREC
Begin DoDot:1
+16 DO DELREC(DURIEN)
+17 SET DURIEN=""
End DoDot:1
+18 ;
+19 QUIT DURIEN
+20 ;
DELSUB(DLIEN,DLSUB) ; delete subrecord - no valid information
+1 ;
+2 NEW FDA,MSG
+3 ;
+4 SET FDA(9002313.4731,DLSUB_","_DLIEN_",",.01)="@"
DE3 ;delete the record
DO FILE^DIE("E","FDA","MSG")
+1 ;successful deletion
IF '$DATA(MSG)
QUIT
+2 ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
IF $DATA(MSG)
DO LOG^ABSPOSL2("DE3^ABSPOSD2",.MSG)
+3 ;
+4 ; delete unsuccessful
+5 KILL ^TMP("ABSP",$JOB,"ABSPOSD2",$JOB,"DELSUB")
+6 SET ^TMP("ABSP",$JOB,"ABSPOSD2",$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.473,DLIEN_",",.01)="@"
DEL3 ;delete the record
DO FILE^DIE("E","FDA","MSG")
+1 ;successful deletion
IF '$DATA(MSG)
QUIT
+2 ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
IF $DATA(MSG)
DO LOG^ABSPOSL2("DEL3^ABSPOSD2",.MSG)
+3 ;
+4 ; delete unsuccessful
+5 KILL ^TMP("ABSP",$JOB,"ABSPOSD2",$JOB,"DELREC")
+6 SET ^TMP("ABSP",$JOB,"ABSPOSD2",$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(DURIEN) ;EP FROM ABSPOSIH
+1 ; establish blank lines for new DUR override entries
+2 ; on NEW POS claims (from page 20 on ABSP DATA INPUT)
+3 ;(block ABSP INPUT 5.1 DUR 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.473,DURIEN,1,REC))
IF '+REC
QUIT
Begin DoDot:1
+9 SET SAVNUM=$PIECE($GET(^ABSP(9002313.473,DURIEN,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.4731,"+1,"_DURIEN_",",.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^ABSPOSD2",.ZERR)
End DoDot:1
+22 ;
+23 ;
+24 QUIT
+25 ;
FLOCK() LOCK +^ABSP(9002313.473):300
QUIT $TEST
FUNLOCK LOCK -^ABSP(9002313.473)
QUIT
ERRHDR() QUIT "ERROR AT $H="_$HOROLOG_" FOR $J="_$JOB
