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

IVMLINS2.m

Go to the documentation of this file. 
  1. IVMLINS2 ;ALB/KCL - IVM INSURANCE POLICY PURGE ; 14 Feb 2014  1:53 PM
  1.  ;;2.0;INCOME VERIFICATION MATCH;**14,34,111,156**; 21-OCT-94;Build 3
  1.  ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  ;
  1.  ;
  1. ASK ; - ask user to 'T'ransfer or 'P'urge IVM insurance policy
  1.  S DIR(0)="S^1:Transfer IVM Insurance Policy to insurance module;2:Purge IVM Insurance Policy;3:Return to Display Screen"
  1.  S DIR("A")="Select Action",DIR("?")="^D HLP1^IVMLINS2"
  1.  D ^DIR K DIR S IVMACT=Y G:$D(DIRUT)!($D(DUOUT))!(IVMACT=3) IVMQ^IVMLINS3
  1.  I IVMACT[1 D TRANSFER^IVMLINS3(0) Q
  1.  ;
  1.  ;
  1. PURGE ; - purge IVM insurance information - ask for reason why
  1.  ;
  1.  W !!,"The 'Purge IVM Insurance Policy' action has been selected."
  1.  ;
  1.  W !!,"This action will cause the insurance information which has been"
  1.  W !,"received from HEC to be deleted from the system!",!,*7
  1.  ;
  1.  W !,"Please select a reason for purging the IVM insurance information."
  1.  S DIC="^IVM(301.91,",DIC("A")="Select reason for purging: ",DIC(0)="QEAMZ"
  1.  D ^DIC K DIC G:Y<0!($D(DTOUT))!($D(DUOUT)) ASK
  1.  S IVMREPTR=+Y
  1.  ;
  1.  ; - ask user 'are you sure you want to purge'
  1.  W ! S DIR(0)="Y",DIR("A")="Are you sure that you want to purge IVM insurance policy"
  1.  ;
  1.  ; - set default = 'NO'
  1.  S DIR("B")="NO"
  1.  ;
  1.  ; - user help
  1.  S DIR("?")="Answer 'Y'ES to go ahead with this action or 'N'O to abort"
  1.  D ^DIR K DIR G:'Y ASK
  1.  ;
  1.  ; - update the INSURANCE SEGMENT multiple stored in (#301.5) file 
  1.  W !!,"Purging the 'Insurance Policy' received from IVM... "
  1.  N DA,DR,DIE,IVMINSST
  1.  ;
  1.  ; stuff UPLOAD INSURANCE DATA(.04) and REASON NOT UPLOADING INSURANCE
  1.  ; (.08)
  1.  S DA=IVMJ,DA(1)=IVMI
  1.  S DIE="^IVM(301.5,"_DA(1)_",""IN"","
  1.  S DR=".04////0;.08////^S X=IVMREPTR" D ^DIE
  1.  ;
  1.  S IVMINSST=0
  1.  D HL7 ;send HL7 message to HEC
  1.  ;
  1. DELETE ; - delete segment name (.02 field of 301.501 multiple) from IVM PATIENT
  1.  ;   file to remove from ASEG cross-reference
  1.  ;
  1.  S DA=IVMJ,DA(1)=IVMI
  1.  S DIE="^IVM(301.5,"_DA(1)_",""IN"",",DR=".02////@" D ^DIE
  1.  ;
  1.  ; - delete incoming segments strings
  1.  K ^IVM(301.5,DA(1),"IN",DA,"ST"),^("ST1")
  1.  W "completed.",!
  1.  ;
  1.  S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR
  1.  ;
  1.  ; - delete entry from the List Manager display once purged
  1.  K ^TMP("IVMIUPL",$J,IVMNAME,IVMI,IVMJ)
  1.  ;
  1.  ; - action completed
  1.  S IVMDONE=1
  1.  D IVMQ^IVMLINS3
  1.  Q
  1.  ;
  1. HL7 ; - send HL7 message to HEC
  1.  ;
  1.  N IVMIN1,IVMIN2,IVMZIV
  1.  N HLEID,HL,HLRESLT
  1.  ;
  1.  ; MESSAGE PROTOCOL
  1.  S HLEID="VAMC "_$P($$SITE^VASITE,"^",3)_" ORU-Z04 SERVER V"
  1.  S HLEID=$O(^ORD(101,"B",HLEID,0))
  1.  ;
  1.  ; - initialize variables for HL7/IVM
  1.  D INIT^IVMUFNC(HLEID,.HL) S HLMTN="ORU"
  1.  I $O(HL(""))="" QUIT  ; the protocol is disabled or could not be initialized
  1.  ;
  1.  ;
  1.  ; - create PID,IN1,ZIV segments
  1.  ;
  1.  ; - PID segment
  1.  K IVMPID,VAFPID
  1.  S IVMPID=$$EN^VAFHLPID(DFN,"1,3,5,7,19")
  1.  I $P(IVMPID,HLFS,20)["P" D PSEUDO^IVMPTRN1
  1.  S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=IVMPID
  1.  K IVMPID,VAFPID
  1.  ;
  1.  ; - IN1 segment
  1.  S IVMIN1="IN1^1"
  1.  S IVMIN2=$G(^IVM(301.5,IVMI,"IN",IVMJ,"ST"))_$G(^("ST1"))
  1.  S $P(IVMIN1,"^",5)=$P(IVMIN2,"^",4)
  1.  S $P(IVMIN1,"^",37)=$P(IVMIN2,"^",36)
  1.  S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=IVMIN1
  1.  ;
  1.  ; - ZIV segment
  1.  S IVMZIV="ZIV^1"
  1.  ; - get ivm ien, strip off date of death
  1.  S $P(IVMZIV,"^",10)=$P($P($G(^IVM(301.5,IVMI,"IN",IVMJ,0)),"^",7),"/")
  1.  S $P(IVMZIV,"^",11)=IVMINSST
  1.  S:IVMINSST=0 $P(IVMZIV,"^",12)=IVMREPTR
  1.  S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=IVMZIV
  1.  ;
  1.  D GENERATE^HLMA(HLEID,"GM",1,.HLRESLT)  ; - create mail message
  1.  K ^TMP("HLS",$J)
  1.  D CLEAN^IVMUFNC
  1.  Q
  1.  ;
  1. DOD ; - Alert user if date of death reported in DHCP or from HEC
  1.  ;
  1.  W !!,*7,"'Date of Death' reported for this patient "
  1.  W $S($P($G(^DPT(+DFN,.35)),"^")]"":"in DHCP as "_$$DAT2^IVMUFNC4($P($G(^DPT(+DFN,.35)),"^")),$P(IVMDND,"^",6)]"":"by HEC as "_$$DAT2^IVMUFNC4($P(IVMDND,"^",6)))_".",!
  1.  S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR
  1.  Q
  1.  ;
  1.  ;
  1. HLP1 ; - help for ASK  Transfer or Purge
  1.  ;
  1.  ; - if user enters single '?'
  1.  I X="?" D
  1.  .W !!,"Enter one of the following responses:"
  1.  .W !,"    1   -  to transfer the Insurance Policy that was received from HEC to the insurance module"
  1.  .W !,"    2   -  to delete the Insurance Policy that was received from HEC"
  1.  .W !,"    3   -  to return to the previous display screen"
  1.  .W !,"   '^'  -  to return to the previous display screen"
  1.  ;
  1.  ; - if user enters double '??'
  1.  I X="??" D
  1.  .W !!,"Entering '1' at this prompt will allow the user to transfer the Insurance Policy"
  1.  .W !,"that was received from HEC to the insurance module.  Entering '2' at this prompt"
  1.  .W !,"will allow the user to delete the Insurance Policy that was received from HEC."
  1.  .W !,"Entering '3' or '^' will abort this action."
  1.  Q