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

ABSPOSUU.m

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