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

ABSPOSC1.m

Go to the documentation of this file.
  1. ABSPOSC1 ; IHS/FCS/DRS - certification testing ;
  1. ;;1.0;PHARMACY POINT OF SALE;;JUN 21, 2001
  1. Q
  1. ;
  1. ; DEVELOPMENT USE ONLY!!! For use when doing certification testing.
  1. ; (Envoy, PCS, etc.)
  1. ;
  1. ; The format has to be in 9002313.92, with NDC BIN number and
  1. ; Envoy plan number filled in.
  1. ; Need to have ^ABSPEI(insurer,100) pointing to the format
  1. ; The insurer comes from $P(^ABSPC(n,0),U,2)
  1. ; Point the insurer to the RESERVED - FOR TESTING dial out.
  1. ;
  1. ; Have to set up an entry in 9002313.31. Fill in values for
  1. ; each of the NCPDP data dictionary fields for the test claim.
  1. ; In general, DON'T fill in 101 BIN Number. It will pick up the
  1. ; Envoy plan number from the 9002313.92 record for you.
  1. ;
  1. ; Once, before doing any of these,
  1. ;
  1. ; DO SETINSUR^ABSPOSC1(low,high pointer to 9002313.31)
  1. ; It prompts for insurer and sets the right insurer into each of
  1. ; those .31 records.
  1. ;
  1. ; ABSP INSURER file - ABSP SETUP INSURER QUICK to attach it to
  1. ; the format you're testing.
  1. ;
  1. ; DO SETDATE^ABSPOSC1(date,low,high pointer to 9002313.31)
  1. ;
  1. ;
  1. ; Then, to test an individual claim:
  1. ;
  1. ; DO TEST^ABSPOSC2(pointer to 9002313.31)
  1. ; But if you're doing a Reversal,
  1. ; instead DO REVERSAL^ABSPOSC2(pointer to 9002313.31)
  1. ; Temporarily uncomment the line in RXI4REV^ABSPOSU
  1. ;
  1. ; DO SEND^ABSPOSC2(pointer to 9002313.31) to transmit
  1. ;
  1. ; DO LOG^ABSPOSC2 to invoke ABSP COMMS LOG
  1. ; RESERVED - FOR TESTING is dial out `5 (saves typing!)
  1. ;
  1. ; DO PRINT^ABSPOSC2(pointer to 9002313.31) to dump raw claim
  1. ; and response packets
  1. ; DO PRINTR^ABSPOSC2(pointer to 9002313.31) to dump response only
  1. ;
  1. ; Use Fileman to print 9002313.02, .03 fields' contents.
  1. ; DO ^%G on ^ABSPC(entry # to look at fields that
  1. ; way, especially the trailing spaces.
  1. ;
  1. ; When there's multiple test claims to send, and the data varies
  1. ; just a little bit, use fileman Transfer Entries, then Enter/Edit
  1. ; to change the few that need to be changed.
  1. ;
  1. Q
  1. ; Utilities to operate on lots of claims at once:
  1. SETDATE(DATE,LOW,HIGH) ; Set DATE FILLED,DATE WRITTEN fields
  1. ; to the given date ; DT is a good choice for parameter 1!
  1. N CLAIM,FIELD
  1. I '$G(DATE) S DATE=DT
  1. F CLAIM=LOW:1:HIGH F FIELD=401,414 D SETFIELD(CLAIM,FIELD,DATE)
  1. Q
  1. SETINSUR(LOW,HIGH) ;
  1. N DIC,X,DTIME,DLAYGO,DINUM,Y,DTOUT,DUOUT
  1. S DIC="^AUTNINS(",DIC(0)="AEMN" D ^DIC Q:Y<1 S Y=+Y
  1. F CLAIM=LOW:1:HIGH D SET0(CLAIM,4,Y)
  1. Q
  1. SET0(CLAIM,PIECE,VALUE) ; set given piece of 0 node of 9002313.31 entry
  1. Q:'$D(^ABSP(9002313.31,CLAIM))
  1. S X=^ABSP(9002313.31,CLAIM,0)
  1. N REF S REF="^ABSP(9002313.31,"_CLAIM_",0)" ;=$ZR
  1. S ^TMP("ABSP",$J,"ABSPOSC1",DT,REF)=X ; save old values, just in case
  1. S $P(X,U,PIECE)=Y
  1. S ^ABSP(9002313.31,CLAIM,0)=X
  1. W "Done for `",CLAIM,": ",X,!
  1. Q
  1. SETFIELD(CLAIM,FIELD,VALUE) ; general - set NCPDP field # value for given
  1. ; entry in 9002313.31 ; both in claim header and prescription detail
  1. N M,N S M=0
  1. F S M=$O(^ABSP(9002313.31,CLAIM,1,M)) Q:'M D ; claim header loop
  1. . N X S X=^ABSP(9002313.31,CLAIM,1,M,0)
  1. . S REF="^ABSP(9002313.31,"_CLAIM_",1,"_M_",0)" ;,REF=$ZR
  1. . D SETF1
  1. S N=0 F S N=$O(^ABSP(9002313.31,CLAIM,2,N)) Q:'N D ; presc loop
  1. . N M S M=0
  1. . F S M=$O(^ABSP(9002313.31,CLAIM,2,N,1,M)) Q:'M D ; field in presc
  1. . . N X S X=^ABSP(9002313.31,CLAIM,2,N,1,M,0)
  1. . . S REF="^ABSP(9002313.31,"_CLAIM_",2,"_N_",1,"_M_",0)" ;,REF=$ZR
  1. . . D SETF1
  1. Q
  1. SETF1 ; given REF, X, FIELD, VALUE
  1. I REF'?1"^ABSP(9002313.31,".E D Q ; safety!!!
  1. . D IMPOSS^ABSPOSUE("P","T","Bad global REF="_REF,,"SETF1",$T(+0))
  1. N F S F=$P(X,U) ; pointer to 9002313.91
  1. N Y S Y=^ABSPF(9002313.91,F,0)
  1. I $P(Y,U)'=FIELD Q ; match on NCPDP Field #
  1. S ^TMP("ABSP",$J,"ABSPOSC1",DT,REF)=X ; save old value of node
  1. S $P(X,U,2)=VALUE ; replace it with the new value
  1. W "Changed ",REF,"=",@REF
  1. S @REF=X
  1. W " to ",@REF,!
  1. Q