ABSPOSUU ; IHS/OIT/CNI/RAN REPORT - utilities[ 05/04/2010 5:18 PM ]
;;1.0;PHARMACY POINT OF SALE;**38,39,40,44,47**;JUN 21, 2001;Build 38
Q
;----------------------------------------------------------------------
;IHS/OIT/CNI/RAN 05042010 patch 38 - Following two subroutines are new and facilitate paging.
PRESSANY() ;EP from ABSPOSR9 and other places IHS/OIT/CNI/RAN 05042010 patch 38
N TIMEOUT
I '$$TOSCREEN^ABSPOSU5 Q 0 ;Only do if printing to screen
N X,I,DONE
S DONE=0
S NLF=+$G(NLF)
S:+$G(TIMEOUT)=0 TIMEOUT=60
F I=1:1:NLF W !
;W !,"Press ENTER to continue: " R X:TIMEOUT
S X=$$FREETEXT^ABSPOSU2("Press ENTER to continue: ",,1,1,1,TIMEOUT) ;IHS/OIT/CNI/SCR patch 39 alpha - reolaced line above
W @IOF
;I X="^" S DONE=1
I (X="^")!(X="^^")!(X=-1) S DONE=1 ;IHS/OIT/CNI/SCR patch 39 alpha
Q DONE
WRITE(TEXT) ;EP from ABSPOSR9 and other places IHS/OIT/CNI/RAN 05042010 patch 38
S ABSPQUIT=0
I $Y>21 S ABSPQUIT=$$PRESSANY
I ABSPQUIT Q ABSPQUIT
W @TEXT
Q ABSPQUIT
GTNDCDRG(ABSPCLMI,ABSPPRX) ;IHS/OIT/CNI/RAN 04282010 patch 39 - Add NDC # and Drug name
;IHS/OIT/RCS 06062012 Patch 44 - Check for Rx # with leading zero's HEAT # 64329
N ABSPDRNM,ABSPNDC,ABSPTRNS,CHECK,CHECK1,CHECK2,CHECK3,D1
S (ABSPDRNM,ABSPNDC)=""
S CHECK1="D2"_ABSPPRX,CHECK2="D20"_ABSPPRX,CHECK3="D2"_$$NFF^ABSPECFM(ABSPPRX,12)
S D1=""
F S D1=$O(^ABSPC(ABSPCLMI,400,D1)) Q:D1="" D
.S CHECK=$P($G(^ABSPC(ABSPCLMI,400,D1,400)),"^",2)
.;I (CHECK=CHECK1)||(CHECK=CHECK2) D ;IHS/OIT/CNI/SCR patch 39 alpha - replaced with line below
.;I ((CHECK=CHECK1)!(CHECK=CHECK2)) D ;IHS/OIT/RCS Patch 44 - replace with line below, HEAT # 64329
.I ((CHECK=CHECK1)!(CHECK=CHECK2)!(CHECK=CHECK3)) D
..S ABSPDRNM=$P($G(^ABSPC(ABSPCLMI,400,D1,0)),"^",4)
..S ABSPNDC=$P($P($G(^ABSPC(ABSPCLMI,400,D1,400)),"^",7),"D7",2)
Q ABSPNDC_"^"_ABSPDRNM
;IHS/OIT/CNI/RAN Patch 40 - Following 5 subroutines used by RCR and CPR reports
GETDO(ABSPRSMI,ABSPRESC) ; GET DO FOR THIS PARTICULAR RESPONSE
N DO,D1,ABSIRESC,ABSORESC
S DO=""
S ABSORESC="0"_ABSPRESC
S D1=0
F S D1=$O(^ABSPR(ABSPRSMI,1000,D1)) Q:+D1=0 D
. S ABSIRESC=$P(^ABSPR(ABSPRSMI,1000,D1,400),U,2)
. I (ABSORESC=ABSIRESC)!(ABSPRESC=ABSIRESC) S DO=D1
I (DO="")&($D(^ABSPR(ABSPRSMI,1000,0))) D
. S D1=$P(^ABSPR(ABSPRSMI,1000,0),U,3)
. I $D(^ABSPR(ABSPRSMI,1000,D1)) S DO=D1
Q DO
INSINQ ;IHS/OIT/RCS 07272012 Patch 44 - Add FM Inquiry for ABSP Insurers
N ABSPSUB,ABM
S ABSPSUB="INSURER" K DIC,DR S DIC="^ABSPEI(" D DIC
Q
;
DIC W !! S DIC("A")="Select INSURER: ",DIC(0)="QEAM"
S DIC("S")="I $P(^(100),U,16)"
D ^DIC
G XIT:X=""!(X["^")!$D(DUOUT)!$D(DTOUT)
I +Y<1 G DIC
S DA=+Y
W:$D(IOF) @IOF W !?80-$L(ABSPSUB)-21\2,"*** ",ABSPSUB," FILE INQUIRY ***" ;OIT/CAS/RCS 050515 Patch 47
S ABM="",$P(ABM,"=",80)="" W !!,ABM K S
D EN^DIQ W ABM
G DIC
;
XIT K ABM,DIR,DIC,DIE
Q
;
INS() ; SELECT THE INSURER OR CHOOSE ALL INSURERS
N DIC,X,Y
S DIC="^ABSPEI("
S DIC(0)="AEMNQZ"
S DIC("A")="Please choose an insurer or leave blank for ALL POS electronic insurers: "
D ^DIC K DIC
I X[U Q -1
I Y=-1 S ABSPINS="ALL"
I Y'=-1 S ABSPINS=$P(Y,U,1),ABSPINSN=$P(Y,U,2)
Q 1
CODE() ;SELECT THE REJECTION CODE OR CHOOSE ALL CODES
;IHS/OIT/SCR 082109 START changes patch 34
N DIC,X,Y
S DIC="^ABSPRJC("
S DIC(0)="AEMNQZ"
S DIC("A")="Please choose a REJECTION CODE or leave blank for ALL: "
D ^DIC K DIC
I X[U Q -1
I Y=-1 S ABSPREJ="ALL"
I Y'=-1 S ABSPREJ=$P(Y,U,1),ABSPREJX=$P(Y,U,2)
Q 1
CLNC() ; PICK WHICH OR ALL CLINIC PHARMACIES
N DIC,X,Y
S DIC="^ABSP(9002313.56,"
S DIC(0)="AEMQVZ"
S DIC("A")="Please Select a Pharmacy or leave blank for ALL: "
D ^DIC K DIC
I X[U Q -1
I Y=-1 S ABSPPPHM="ALL"
I Y>-1 S ABSPPPHM=$P(Y,U,1),ABSPPHMN=$P(Y,U,2)
Q 1
USER() ; PICK WHICH OR ALL NEW PERSON
N DIC,X,Y
S DIC="^VA(200,"
S DIC(0)="AEMQVZ"
S DIC("A")="Please Select a User or leave blank for ALL: "
D ^DIC K DIC
I X["^" Q -1
I Y=-1 S ABSPUSER="ALL"
I Y>-1 S ABSPUSER=$P(Y,"^",1)
Q 1
ABSPOSUU ; IHS/OIT/CNI/RAN REPORT - utilities[ 05/04/2010 5:18 PM ]
+1 ;;1.0;PHARMACY POINT OF SALE;**38,39,40,44,47**;JUN 21, 2001;Build 38
+2 QUIT
+3 ;----------------------------------------------------------------------
+4 ;IHS/OIT/CNI/RAN 05042010 patch 38 - Following two subroutines are new and facilitate paging.
PRESSANY() ;EP from ABSPOSR9 and other places IHS/OIT/CNI/RAN 05042010 patch 38
+1 NEW TIMEOUT
+2 ;Only do if printing to screen
IF '$$TOSCREEN^ABSPOSU5
QUIT 0
+3 NEW X,I,DONE
+4 SET DONE=0
+5 SET NLF=+$GET(NLF)
+6 IF +$GET(TIMEOUT)=0
SET TIMEOUT=60
+7 FOR I=1:1:NLF
WRITE !
+8 ;W !,"Press ENTER to continue: " R X:TIMEOUT
+9 ;IHS/OIT/CNI/SCR patch 39 alpha - reolaced line above
SET X=$$FREETEXT^ABSPOSU2("Press ENTER to continue: ",,1,1,1,TIMEOUT)
+10 WRITE @IOF
+11 ;I X="^" S DONE=1
+12 ;IHS/OIT/CNI/SCR patch 39 alpha
IF (X="^")!(X="^^")!(X=-1)
SET DONE=1
+13 QUIT DONE
WRITE(TEXT) ;EP from ABSPOSR9 and other places IHS/OIT/CNI/RAN 05042010 patch 38
+1 SET ABSPQUIT=0
+2 IF $Y>21
SET ABSPQUIT=$$PRESSANY
+3 IF ABSPQUIT
QUIT ABSPQUIT
+4 WRITE @TEXT
+5 QUIT ABSPQUIT
GTNDCDRG(ABSPCLMI,ABSPPRX) ;IHS/OIT/CNI/RAN 04282010 patch 39 - Add NDC # and Drug name
+1 ;IHS/OIT/RCS 06062012 Patch 44 - Check for Rx # with leading zero's HEAT # 64329
+2 NEW ABSPDRNM,ABSPNDC,ABSPTRNS,CHECK,CHECK1,CHECK2,CHECK3,D1
+3 SET (ABSPDRNM,ABSPNDC)=""
+4 SET CHECK1="D2"_ABSPPRX
SET CHECK2="D20"_ABSPPRX
SET CHECK3="D2"_$$NFF^ABSPECFM(ABSPPRX,12)
+5 SET D1=""
+6 FOR
SET D1=$ORDER(^ABSPC(ABSPCLMI,400,D1))
IF D1=""
QUIT
Begin DoDot:1
+7 SET CHECK=$PIECE($GET(^ABSPC(ABSPCLMI,400,D1,400)),"^",2)
+8 ;I (CHECK=CHECK1)||(CHECK=CHECK2) D ;IHS/OIT/CNI/SCR patch 39 alpha - replaced with line below
+9 ;I ((CHECK=CHECK1)!(CHECK=CHECK2)) D ;IHS/OIT/RCS Patch 44 - replace with line below, HEAT # 64329
+10 IF ((CHECK=CHECK1)!(CHECK=CHECK2)!(CHECK=CHECK3))
Begin DoDot:2
+11 SET ABSPDRNM=$PIECE($GET(^ABSPC(ABSPCLMI,400,D1,0)),"^",4)
+12 SET ABSPNDC=$PIECE($PIECE($GET(^ABSPC(ABSPCLMI,400,D1,400)),"^",7),"D7",2)
End DoDot:2
End DoDot:1
+13 QUIT ABSPNDC_"^"_ABSPDRNM
+14 ;IHS/OIT/CNI/RAN Patch 40 - Following 5 subroutines used by RCR and CPR reports
GETDO(ABSPRSMI,ABSPRESC) ; GET DO FOR THIS PARTICULAR RESPONSE
+1 NEW DO,D1,ABSIRESC,ABSORESC
+2 SET DO=""
+3 SET ABSORESC="0"_ABSPRESC
+4 SET D1=0
+5 FOR
SET D1=$ORDER(^ABSPR(ABSPRSMI,1000,D1))
IF +D1=0
QUIT
Begin DoDot:1
+6 SET ABSIRESC=$PIECE(^ABSPR(ABSPRSMI,1000,D1,400),U,2)
+7 IF (ABSORESC=ABSIRESC)!(ABSPRESC=ABSIRESC)
SET DO=D1
End DoDot:1
+8 IF (DO="")&($DATA(^ABSPR(ABSPRSMI,1000,0)))
Begin DoDot:1
+9 SET D1=$PIECE(^ABSPR(ABSPRSMI,1000,0),U,3)
+10 IF $DATA(^ABSPR(ABSPRSMI,1000,D1))
SET DO=D1
End DoDot:1
+11 QUIT DO
INSINQ ;IHS/OIT/RCS 07272012 Patch 44 - Add FM Inquiry for ABSP Insurers
+1 NEW ABSPSUB,ABM
+2 SET ABSPSUB="INSURER"
KILL DIC,DR
SET DIC="^ABSPEI("
DO DIC
+3 QUIT
+4 ;
DIC WRITE !!
SET DIC("A")="Select INSURER: "
SET DIC(0)="QEAM"
+1 SET DIC("S")="I $P(^(100),U,16)"
+2 DO ^DIC
+3 IF X=""!(X["^")!$DATA(DUOUT)!$DATA(DTOUT)
GOTO XIT
+4 IF +Y<1
GOTO DIC
+5 SET DA=+Y
+6 ;OIT/CAS/RCS 050515 Patch 47
IF $DATA(IOF)
WRITE @IOF
WRITE !?80-$LENGTH(ABSPSUB)-21\2,"*** ",ABSPSUB," FILE INQUIRY ***"
+7 SET ABM=""
SET $PIECE(ABM,"=",80)=""
WRITE !!,ABM
KILL S
+8 DO EN^DIQ
WRITE ABM
+9 GOTO DIC
+10 ;
XIT KILL ABM,DIR,DIC,DIE
+1 QUIT
+2 ;
INS() ; SELECT THE INSURER OR CHOOSE ALL INSURERS
+1 NEW DIC,X,Y
+2 SET DIC="^ABSPEI("
+3 SET DIC(0)="AEMNQZ"
+4 SET DIC("A")="Please choose an insurer or leave blank for ALL POS electronic insurers: "
+5 DO ^DIC
KILL DIC
+6 IF X[U
QUIT -1
+7 IF Y=-1
SET ABSPINS="ALL"
+8 IF Y'=-1
SET ABSPINS=$PIECE(Y,U,1)
SET ABSPINSN=$PIECE(Y,U,2)
+9 QUIT 1
CODE() ;SELECT THE REJECTION CODE OR CHOOSE ALL CODES
+1 ;IHS/OIT/SCR 082109 START changes patch 34
+2 NEW DIC,X,Y
+3 SET DIC="^ABSPRJC("
+4 SET DIC(0)="AEMNQZ"
+5 SET DIC("A")="Please choose a REJECTION CODE or leave blank for ALL: "
+6 DO ^DIC
KILL DIC
+7 IF X[U
QUIT -1
+8 IF Y=-1
SET ABSPREJ="ALL"
+9 IF Y'=-1
SET ABSPREJ=$PIECE(Y,U,1)
SET ABSPREJX=$PIECE(Y,U,2)
+10 QUIT 1
CLNC() ; PICK WHICH OR ALL CLINIC PHARMACIES
+1 NEW DIC,X,Y
+2 SET DIC="^ABSP(9002313.56,"
+3 SET DIC(0)="AEMQVZ"
+4 SET DIC("A")="Please Select a Pharmacy or leave blank for ALL: "
+5 DO ^DIC
KILL DIC
+6 IF X[U
QUIT -1
+7 IF Y=-1
SET ABSPPPHM="ALL"
+8 IF Y>-1
SET ABSPPPHM=$PIECE(Y,U,1)
SET ABSPPHMN=$PIECE(Y,U,2)
+9 QUIT 1
USER() ; PICK WHICH OR ALL NEW PERSON
+1 NEW DIC,X,Y
+2 SET DIC="^VA(200,"
+3 SET DIC(0)="AEMQVZ"
+4 SET DIC("A")="Please Select a User or leave blank for ALL: "
+5 DO ^DIC
KILL DIC
+6 IF X["^"
QUIT -1
+7 IF Y=-1
SET ABSPUSER="ALL"
+8 IF Y>-1
SET ABSPUSER=$PIECE(Y,"^",1)
+9 QUIT 1
