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

ABSPOSE1.m

Go to the documentation of this file. 
  1. ABSPOSE1 ; IHS/SD/lwj - E1 gereration routine ; [ 10/24/2005 10:09:07 AM ]
  1.  ;;1.0;PHARMACY POINT OF SALE;**14,15,16,48**;JUN 21, 2001;Build 38
  1.  ;
  1.  ;IHS/SD/lwj 10/24/05  Medicare Part D E1 Transmission routine
  1.  ;  This routine will:
  1.  ;    * prompt the user for which patient an E1 should be generated for
  1.  ;    * determine if there are multiple pharmacies and prompt for one
  1.  ;    * determine if a previous E1 was sent - if so, it will prompt if
  1.  ;       the user would like to create a new E1
  1.  ;    * create the shell of the ^ABSPE entry
  1.  ;    * generate the E1 transmission
  1.  ;    * call ^ABSPOSAE to send the E1 and process the response
  1.  ;    * prompt for another patient
  1.  ;
  1.  ; 11/15/05 WE WERE ONLY ABLE TO TEST WITH NDC TROOP FACILITATION -
  1.  ;  ADJUSTMENTS WILL BE NEEDED WHEN WE KNOW MORE AND ARE READY TO
  1.  ;  GO LIVE.
  1.  ;
  1.  ; IHS/SD/RLT - 1/13/06 - Patch 15
  1.  ;    Pam Swchweitzer requested the program to end when a blank
  1.  ;    patient is entered.
  1.  ;
  1.  ; IHS/SD/RLT - 2/3/06 - Patch 16
  1.  ;    Fixed display error for fields 504 and 526.
  1.  ;
  1.  ;    Fixed elig file write and lookup.  Changed X from name to `IEN so
  1.  ;    fileman is not confused on names that bring up muliple records. 
  1.  ;
  1.  Q
  1. MAIN ;EP
  1.  N POP
  1.  S POP=0
  1.  ;
  1.  F  D PROCESS  Q:POP
  1.  ;
  1.  Q
  1. PROCESS ;
  1.  N E1PNAM,E1PIEN,E1PINFO,E1PHARM,E1IEN
  1.  ;
  1.  S POP=1
  1.  ; prompt for the patient
  1.  S E1PINFO=$$GETPAT
  1.  Q:E1PINFO<1
  1.  S E1PIEN=$P(E1PINFO,U)  ;VA(200 patient IEN
  1.  S E1PNAM=$P(E1PINFO,U,2)  ;VA(200 patient name
  1.  ;
  1.  ; determine the pharmacy to send on behalf of
  1.  S E1PHARM=$$GETPHARM    ;E1PHARM - ien into ABSP(9002313.56
  1.  Q:E1PHARM<1
  1.  ;
  1.  ; establish the ^ABSPE record to work with
  1.  S E1IEN=$$GETABSPE    ;E1IEN - ien into ^ABSPE
  1.  Q:E1IEN<1    ;must have had a prev one and didn't want a new one
  1.  ;
  1.  ;create the transmission
  1.  D CRTE1
  1.  U $P W !!,"Transmitting eligibility check, please stand by.....",!!
  1.  D SEND^ABSPOSAE(TDATA,E1IEN)  ;send the transaction
  1.  S POP=0
  1.  ;
  1.  ;
  1.  ;
  1.  Q
  1. GETPAT() ;Prompt the user for which patient they would like to generate an E1 for
  1.  ;
  1.  N ABSPDUZ2,PATDONE,Y,DIC
  1.  N X                                                         ;RLT - Patch 15
  1.  S X=""                                                      ;RLT - Patch 15
  1.  ;
  1.  S PATDONE=0   ;set to one when we are done prompting
  1.  S Y=0
  1.  S ABSPDUZ2=+$G(DUZ(2)),DUZ(2)=0
  1.  ;
  1.  U $P W !!!
  1.  ;
  1.  S DIC=2,DIC(0)="AEMQZ"
  1.  S DIC("A")="Generate eligibility chk (Med Part D) for which patient? "
  1.  F  D  Q:PATDONE
  1.  . D ^DIC
  1.  . U $P W !
  1.  . ;S:(($G(DUOUT))!($G(DTOUT))!(Y>0)) PATDONE=1              ;RLT - PATCH 15
  1.  . S:(($G(DUOUT))!($G(DTOUT))!(Y>0)!(X="")) PATDONE=1        ;RLT - PATCH 15
  1.  K DIC
  1.  S DUZ(2)=ABSPDUZ2
  1.  ;
  1.  Q Y
  1. GETPHARM() ;when more than one pharmacy is set up for this site, prompt
  1.  ; for which one to use for the E1 transmission (need to know which
  1.  ; NCPDP & terminal ID to use)
  1.  ;
  1.  N PHARM,HLDPHARM,Y,PDONE,PHMCNT,DIC
  1.  ;
  1.  S (PHMCNT,PDONE,PHARM,Y)=0   ;initialize beginning variables
  1.  ;
  1.  F  S PHARM=$O(^ABSP(9002313.56,PHARM)) Q:'+PHARM  D
  1.  . S PHMCNT=PHMCNT+1
  1.  . S:PHMCNT=1 HLDPHARM=PHARM
  1.  Q:PHMCNT=1 HLDPHARM
  1.  ;
  1.  W !!
  1.  S DIC=9002313.56,DIC(0)="AEMQZ"
  1.  S DIC("B")=$P($G(^ABSP(9002313.56,HLDPHARM,0)),U)
  1.  S DIC("A")="Please specify the pharmacy: "
  1.  F  D  Q:PDONE
  1.  . D ^DIC
  1.  . U $P W !
  1.  . S:(($G(DUOUT))!($G(DTOUT))!(Y>0)) PDONE=1
  1.  ;
  1.  Q +Y
  1.  ;
  1. GETABSPE() ; if an E1 was previously sent for this patient, find it
  1.  ; and prompt if the user wishes to send again.  If one doesn't
  1.  ; exist, we'll ask fileman to create it for us now.
  1.  ;
  1.  N X,DIC,DLAYGO,Y,NEWE1,CRTNWE1,E1IEN
  1.  S DIC="^ABSPE(",DIC(0)="XZ"
  1.  ;S X=E1PNAM                             ;RLT - 2/3/06 - Patch 16
  1.  S X="`"_E1PIEN                          ;RLT - 2/3/06 - Patch 16
  1.  S (NEWE1,CRTNWE1)=0
  1.  ;
  1.  ;let's look for an existing E1 for this patient
  1.  D ^DIC
  1.  K DIC
  1.  S E1IEN=+Y
  1.  S:E1IEN<1 CRTNWE1=1   ;patient doesn't exist - add them
  1.  S:E1IEN>0 NEWE1=$$PRMPT(E1IEN)  ;exist - do they want to send again?
  1.  ;
  1.  ; Yes - they want to send again - delete the current entry
  1.  I NEWE1 D
  1.  . N DIK,DA
  1.  . S DIK="^ABSPE("
  1.  . S DA=E1IEN
  1.  . D ^DIK    ;kill the previous entry
  1.  . K DIK,DA
  1.  . S CRTNWE1=1
  1.  ;
  1.  ; creat a new entry
  1.  I CRTNWE1 D
  1.  . S DIC="^ABSPE("
  1.  . ;S X=E1PNAM                             ;RLT - 2/3/06 - Patch 16
  1.  . S X="`"_E1PIEN                          ;RLT - 2/3/06 - Patch 16
  1.  . S DLAYGO=9002313.7,DIC(0)="LXZ"
  1.  . D ^DIC
  1.  ;
  1.  Q +Y
  1.  ;
  1. PRMPT(E1IEN) ; The patient has previously had an E1 sent - if the last response
  1.  ; was accepted, let's display the previous response and prompt if
  1.  ; the wants to send another E1 at this time
  1.  ;
  1.  N RESULT,DIR,STATUS
  1.  ;
  1.  ; if the previous result was an error, let's send a new E1
  1.  S RESULT=$$GET1^DIQ(9002313.7,E1IEN_",",9999999,"E")
  1.  Q:RESULT'="" 1
  1.  ;
  1.  ; if the status reflects the E1 was rejected, let's send a new one
  1.  S STATUS=$$GET1^DIQ(9002313.7,E1IEN_",",112,"E")
  1.  Q:STATUS="R" 1
  1.  ;
  1.  ;
  1.  U $P
  1.  W !!!,"A check was previously submitted for this patient: "
  1.  D DISPLAY(E1IEN)
  1.  ;
  1.  S DIR("A")="Would you like to send a new eligibility check? "
  1.  S DIR("B")="Y"
  1.  S DIR(0)="YAO"
  1.  D ^DIR
  1.  ;
  1.  Q Y
  1. CRTE1 ; This subroutine will:
  1.  ;   * facilitate the creation of the needed E1 header, patient
  1.  ;     and insurance segments (transmission record is TDATA)
  1.  ;   *  update ^ABSPE with the patient/insurance trans data
  1.  ;   *  create raw transmission record for ^ABSPE
  1.  ;
  1.  ;
  1.  N FS,SS
  1.  N DIE,DA,DR
  1.  ;N TDATA
  1.  ;
  1.  S TDATA=""
  1.  S DIE="^ABSPE(",DA=E1IEN
  1.  S FS=$C(28),SS=$C(30)     ;field and segment separators
  1.  ;
  1.  D HEADER
  1.  D PATIENT
  1.  D INSURER
  1.  ;
  1.  ;update ^ABSPE with the patient and insurance information
  1.  ; for the transmission
  1.  ;
  1.  D ^DIE
  1.  ;
  1.  ;update ^ABSPE with raw message
  1.  D RAWTRANS
  1.  ;
  1.  Q
  1.  ;
  1.  ; for the Medicare Part D transmission.  If other E1's are ever produced
  1.  ; this will need to be altered to pull the plan from some other source.
  1.  ; Because of the tight time line for the Medicare Part D E1, we forced
  1.  ; the plan to only work for that plan (006015).  The header segment is
  1.  ; fixed length, will all elements required.
  1.  ;
  1.  ; 11/14/05  THIS SUBROUTINE MUST BE REVIEWED AND ADJUSTED FOR GO LIVE -
  1.  ;  CURRENTLY SET TO WORK WITH NDC TROPP FACILITATION TESTING - SEE
  1.  ;  COMMENTS BELOW
  1.  ;
  1.  N XDATA
  1.  ;
  1.  S XDATA=$G(^ABSP(9002313.56,E1PHARM,0))  ;E1PHARM set from call to GETPHARM
  1.  ;
  1.  ;101 BIN (Emdeon plan # hard coded to 006015) + 102 Version (always 51) +
  1.  ;103 Trans Code (always E1)
  1.  S TDATA="00601551E1"
  1.  ;S TDATA="00998851E1"  ;Bart's test system
  1.  ;S TDATA="01172751E1"   ;good way to force EV rejection
  1.  ;
  1.  ;104 Processor control number (Emdeon terminal id for sending pharmacy)
  1.  S TDATA=TDATA_$TR($J($P(XDATA,U,6),10)," ","0")
  1.  ;
  1.  ;109 Transaction Count (1 for the E1)+202 Service Prov ID Qual (always 07)
  1.  S TDATA=TDATA_107
  1.  ;
  1.  ;201 Service Provide ID
  1.  S TDATA=TDATA_$$ANFF^ABSPECFM($P(XDATA,U,2),15)  ;NCPDP number
  1.  ;S TDATA=TDATA_$$ANFF^ABSPECFM("1234567",15)  ;forces rejection
  1.  ;S TDATA=TDATA_$$ANFF^ABSPECFM("0000238",15)  ;good one for testing
  1.  ;
  1.  ;401 Data of Service (will always use current date for the E1)
  1.  S TDATA=TDATA_$$DTF1^ABSPECFM(DT)
  1.  ;
  1.  ;110 Software Vendor/Certification ID
  1.  S TDATA=TDATA_$$ANFF^ABSPECFM(" ",10)  ;real??  don't know yet
  1.  ;S TDATA=TDATA_$$ANFF^ABSPECFM("TATA",10) ;Bart's testing system
  1.  ;S TDATA=TDATA_$$ANFF^ABSPECFM("TROOPELIG",10) ;NDC's testing system
  1.  ;
  1.  ;add segment and field separators
  1.  S TDATA=TDATA_SS_FS
  1.  ;
  1.  Q
  1. PATIENT ; This subroutine is responsible for creating the patient segment, and
  1.  ; for updating the ^ABSPE record with this information.
  1.  ;
  1.  ; 11/14/05 CHANGES MAY BE NEEDED - THIS SUBROUTINE IS CURRENTLY SET TO
  1.  ;  WORK WITH NDC TESTING - SEE COMMENTS BELOW
  1.  ;
  1.  N ABSP304,ABSP305,ABSP310,ABSP311,ABSP332,ABSP323,ABSP324
  1.  N ABSP325,ABSP326,XDATA,XDATA11,ABSPNAM
  1.  ;
  1.  N STCODE
  1.  ;
  1.  S XDATA=$G(^DPT(E1PIEN,0))  ;patient data
  1.  S XDATA11=$G(^DPT(E1PIEN,.11)) ;address information
  1.  ;
  1.  ;preset field 111 to AM01 (segment identification)
  1.  S TDATA=TDATA_"AM01"_FS
  1.  ;
  1.  ;304 Date of Birth (format
  1.  S ABSP304=$$DTF1^ABSPECFM($P(XDATA,U,3))
  1.  S TDATA=TDATA_"C4"_ABSP304_FS
  1.  S DR="304////"_ABSP304_";"
  1.  ;
  1.  ;305 Patient Gender
  1.  S ABSP305=$E($P(XDATA,U,2),1,1)
  1.  S ABSP305=$S(ABSP305="M":"1",ABSP305="F":"2",1:"0")
  1.  S ABSP305=$$NFF^ABSPECFM(ABSP305,1)
  1.  S TDATA=TDATA_"C5"_ABSP305_FS
  1.  S DR=DR_"305////"_ABSP305_";"
  1.  ;
  1.  ;prepare for patient name - try to use the entry
  1.  ; from the Medicare Eligible file is its there, if
  1.  ; not, use the patient name
  1.  S ABSPNAM=$$GET1^DIQ(9000003,E1PIEN_",",.01,"E")
  1.  S:ABSPNAM="" ABSPNAM=$P(XDATA,U)
  1.  ;
  1.  ;310 Patient First Name
  1.  S ABSP310=$$ANFF^ABSPECFM($P($P(ABSPNAM,",",2)," "),12)
  1.  S TDATA=TDATA_"CA"_ABSP310_FS
  1.  S DR=DR_"310////"_ABSP310_";"
  1.  ;
  1.  ;311 Patient Last Name
  1.  S ABSP311=$$ANFF^ABSPECFM($P(ABSPNAM,",",1),15)
  1.  S TDATA=TDATA_"CB"_ABSP311_FS
  1.  S DR=DR_"311////"_ABSP311_";"
  1.  ;
  1.  ;322 Patient Street Address - not used yet
  1.  ;S ABSP322=$$ANFF^ABSPECFM($P(XDATA11,U),30)
  1.  ;S TDATA=TDATA_"CM"_ABSP322_FS
  1.  ;S DR=DR_"322////"_ABSP322_";"
  1.  ;
  1.  ;323 Patient City Address  - not used yet
  1.  ;S ABSP323=$$ANFF^ABSPECFM($P(XDATA11,U,4),20)
  1.  ;S TDATA=TDATA_"CN"_ABSP323_FS
  1.  ;S DR=DR_"323////"_ABSP323_";"
  1.  ;
  1.  ;324 Patient State/Province Address - not used yet
  1.  ;S ABSP324=""
  1.  ;S STCODE=$P(XDATA11,U,5)
  1.  ;S:STCODE'="" ABSP324=$P($G(^DIC(5,STCODE,0)),U,2)
  1.  ;S ABSP324=$$ANFF^ABSPECFM(ABSP324,2)
  1.  ;S TDATA=TDATA_"CO"_ABSP324_FS
  1.  ;S DR=DR_"324////"_ABSP324_";"
  1.  ;
  1.  ;325 Patient Zip/Postal Zone - currently last field
  1.  ; so the segment separator must be there
  1.  S ABSP325=$$ANFF^ABSPECFM($P(XDATA11,U,6),15)
  1.  S TDATA=TDATA_"CP"_ABSP325_SS_FS
  1.  S DR=DR_"325////"_ABSP325_";"
  1.  ;
  1.  ;326 Patient Phone Number - not used yet
  1.  ; if they want this, remove the segment separator from
  1.  ; the zip code
  1.  ;S ABSP326=$TR($$GET1^DIQ(2,E1PIEN_",",.131,"E"),"()-")
  1.  ;S ABSP326=$$NFF^ABSPECFM(ABSP326,10)
  1.  ;S TDATA=TDATA_"CQ"_ABSP326_SS_FS
  1.  ;S DR=DR_"326////"_ABSP326_";"
  1.  ;
  1.  Q
  1. INSURER ; this subroutine will pull together the information
  1.  ; needed for the E1 insurance segment
  1.  ;
  1.  ; 11/15/05 CHANGES MAY BE NEEDED - THIS ROUTINE IS SET
  1.  ;  TO WORK WITH NDC TROOP FACILITATION TESTING - SEE
  1.  ;  COMMENTS BELOW
  1.  ;
  1.  N ABSP302,ABSP301,ABSPCID
  1.  ;
  1.  S TDATA=TDATA_"AM04"_FS
  1.  ;
  1.  ;302 Cardholder ID - will try to retrieve medicare card holder
  1.  ; id, if not available use last 4 of SSN
  1.  S ABSP302=$$GET1^DIQ(9000003,E1PIEN_",",.03,"E")
  1.  I ABSP302="" D
  1.  . S ABSP302=$$GET1^DIQ(2,E1PIEN_",",.09,"E")
  1.  . S ABSP302=$E(ABSP302,$L(ABSP302)-3,$L(ABSP302))
  1.  ;
  1.  S ABSP302=$TR(ABSP302,"-/.","")
  1.  S ABSP302=$$ANFF^ABSPECFM(ABSP302,20)
  1.  S TDATA=TDATA_"C2"_ABSP302
  1.  ;S TDATA=TDATA_"C2"_ABSP302_FS  ; Bart's system
  1.  S DR=DR_"302////"_ABSP302
  1.  ;
  1.  ;301 group number - just for testing
  1.  ; Bart's system - don't know if this fld
  1.  ; will be needed for live - put the fld
  1.  ; separator on 302 (above) if 301 is needed
  1.  ;S ABSP301=$$ANFF^ABSPECFM("TATA",10)
  1.  ;S TDATA=TDATA_"C1"_ABSP301
  1.  ;S DR=DR_"301////"_ABSP301
  1.  ;
  1.  Q
  1. RAWTRANS ; create the raw transmission entry in ^ABSPE
  1.  ;
  1.  N WP,I,ZERR  ; /IHS/OIT/RAM ; 12 JUN 17 ; ADD DBS CALL ERROR RETURN VARIABLE
  1.  ;
  1.  F I=1:100:$L(TDATA) S WP(I/100+1,0)=$E(TDATA,I,I+99)
  1.  D WP^DIE(9002313.7,E1IEN_",",1000,"","WP","ZERR") ; /IHS/OIT/RAM ; 12 JUN 17 ; UPDATE DBS CALL TO ALLOW FOR ERROR RETURN.
  1.  I $D(ZERR) D LOG^ABSPOSL2("RAWTRANS^ABSPOSE1",.ZERR) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
  1.  ;
  1.  Q
  1. DISPLAY(E1IEN) ;EP - display the E1's results
  1.  ;
  1.  N ABSPPNAM,ABSP112,ABSP504,ABSP526,ABSPINS,COVER
  1.  N ABSP503,ABSPCUT,ABSPSTR,ABSP03
  1.  S (ABSPPNAM,ABSP112,ABSP504,ABSP503,ABSP536)=""
  1.  ;
  1.  S ABSPPNAM=$$GET1^DIQ(9002313.7,E1IEN_",",.01,"E")
  1.  S ABSP03=$$GET1^DIQ(9002313.7,E1IEN_",",.03,"E")
  1.  S ABSP112=$$GET1^DIQ(9002313.7,E1IEN_",",112,"E")
  1.  S ABSP503=$$GET1^DIQ(9002313.7,E1IEN_",",503,"E")
  1.  S ABSP504=$$GET1^DIQ(9002313.7,E1IEN_",",504,"E")
  1.  S ABSP526=$$GET1^DIQ(9002313.7,E1IEN_",",526,"E")
  1.  S ABSPINS=ABSP504_ABSP526
  1.  D:ABSPINS["&" PARSEIT(ABSPINS,.COVER)
  1.  ;
  1.  W !,"On:               ",ABSP03
  1.  W !,"Patient Name:     ",ABSPPNAM
  1.  W !,"Status:           ",ABSP112
  1.  W !,"Authorization #:  ",ABSP503
  1.  ;
  1.  I '$D(COVER("COUNT")) D
  1.  . W !,"Result:"
  1.  . ;
  1.  . N LINECNT                             ;RLT - 2/3/06 - Patch 16
  1.  . S LINECNT=1                           ;RLT - 2/3/06 - Patch 16
  1.  . ;
  1.  . I $D(ABSP504) D
  1.  .. S ABSPSTR=1
  1.  .. I $L(ABSP504)>50 D                   ;RLT - 2/3/06 - Patch 16
  1.  ... S LINECNT=$L(ABSP504)\50            ;RLT - 2/3/06 - Patch 16
  1.  ... S:LINECNT#50'=0 LINECNT=LINECNT+1   ;RLT - 2/3/06 - Patch 16
  1.  .. F ABSPCUT=1:1:LINECNT D              ;RLT - 2/3/06 - Patch 16
  1.  ... W ?18,$E(ABSP504,ABSPSTR,ABSPSTR+50),!,"  "
  1.  ... S ABSPSTR=ABSPSTR+50
  1.  . ;
  1.  . S LINECNT=1
  1.  . ;
  1.  . I $D(ABSP526) D
  1.  .. S ABSPSTR=1
  1.  .. I $L(ABSP526)>50 D                   ;RLT - 2/3/06 - Patch 16
  1.  ... S LINECNT=$L(ABSP526)\50            ;RLT - 2/3/06 - Patch 16
  1.  ... S:LINECNT#50'=0 LINECNT=LINECNT+1   ;RLT - 2/3/06 - Patch 16
  1.  .. F ABSPCUT=1:1:LINECNT D              ;RLT - 2/3/06 - Patch 16
  1.  ... W ?18,$E(ABSP526,ABSPSTR,ABSPSTR+50),!,"  "
  1.  ... S ABSPSTR=ABSPSTR+50
  1.  . ;
  1.  . W !!
  1.  ;
  1.  F INSCNT=1:1:$G(COVER("COUNT"))  D
  1.  . W !,"Insurance Level:  ",COVER(INSCNT,"INS LVL")
  1.  . W !,"   BIN:           ",COVER(INSCNT,"BIN")
  1.  . W !,"   PCN:           ",COVER(INSCNT,"PCN")
  1.  . W !,"   GROUP:         ",COVER(INSCNT,"GROUP")
  1.  . W !,"   CARDHOLDER ID: ",COVER(INSCNT,"CARD ID")
  1.  . W !,"   PERSON CODE:   ",COVER(INSCNT,"PERSON CD")
  1.  . W !,"   PHONE NUMBER:  ",COVER(INSCNT,"PHONE #")
  1.  . W !
  1.  ;
  1.  ;
  1.  Q
  1.  ;
  1. PARSEIT(INSFLD,COVER) ; The 504 and 526 fields may actually have
  1.  ; detailed insurance information in them - we need to break
  1.  ; them down for reporting purposes.
  1.  ;
  1.  N INSCNT,NOMORE
  1.  S INSCNT=1
  1.  S NOMORE=0
  1.  ;
  1.  F  D  Q:NOMORE
  1.  . S INSREC=$P(INSFLD,"&",INSCNT)
  1.  . S:INSREC="" NOMORE=1
  1.  . Q:NOMORE
  1.  . I INSCNT=1 D
  1.  .. S COVER(INSCNT,"INS LVL")=$P(INSREC,"#",2)
  1.  .. S COVER(INSCNT,"BIN")=$P($P(INSREC,"#",3),":",2)
  1.  .. S COVER(INSCNT,"PCN")=$P($P(INSREC,"#",4),":",2)
  1.  .. S COVER(INSCNT,"GROUP")=$P($P(INSREC,"#",5),":",2)
  1.  .. S COVER(INSCNT,"CARD ID")=$P($P(INSREC,"#",6),":",2)
  1.  .. S COVER(INSCNT,"PERSON CD")=$P($P(INSREC,"#",7),":",2)
  1.  .. S COVER(INSCNT,"PHONE #")=$P($P(INSREC,"#",8),":",2)
  1.  . I INSCNT'=1 D
  1.  .. S COVER(INSCNT,"INS LVL")=$P(INSREC,"#")
  1.  .. S COVER(INSCNT,"BIN")=$P($P(INSREC,"#",2),":",2)
  1.  .. S COVER(INSCNT,"PCN")=$P($P(INSREC,"#",3),":",2)
  1.  .. S COVER(INSCNT,"GROUP")=$P($P(INSREC,"#",4),":",2)
  1.  .. S COVER(INSCNT,"CARD ID")=$P($P(INSREC,"#",5),":",2)
  1.  .. S COVER(INSCNT,"PERSON CD")=$P($P(INSREC,"#",6),":",2)
  1.  .. S COVER(INSCNT,"PHONE #")=$P($P(INSREC,"#",7),":",2)
  1.  . S INSCNT=INSCNT+1
  1.  ;
  1.  S COVER("COUNT")=INSCNT-1
  1.  ;
  1.  Q