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

PRCPHLFM.m

Go to the documentation of this file.
  1. PRCPHLFM ;WISC/CC/DWA-build HL7 messages for item maintenance ;11/5/03 22:34
  1. V ;;5.1;IFCAP;**1,24,52,63**;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. Q
  1. ;
  1. BLDSEG(ACTION,ITEM,SIP) ;
  1. ;
  1. ; ACTION (1st '^' piece) 1 if add, 2 if delete, 3 if update
  1. ; (2nd '^' piece) flag indicating txn MUST be built
  1. ; ITEM the number of the item affected
  1. ; SIP the number of the secondary inventory point affected
  1. ; 0 (zero) for non-station specific edits (from PRCHE)
  1. ; MSG 0 to suppress messages, 1 to display them
  1. ;
  1. ; if this is a non-station specific edit (i.e. from PRCHE)
  1. ;
  1. N MSG,PUSH S MSG=1
  1. S PUSH=0
  1. I $P(ACTION,"^",2)=1 S PUSH=1
  1. I ACTION=3,SIP=0 D QUIT
  1. . N SS,IME
  1. . S SS=0,IME=0 ; entry from PRCHE
  1. . F S SS=$O(^PRCP(445.5,SS)) Q:'+SS D
  1. . . ; send transaction to non-station specific SS housing the item
  1. . . I $P(^PRCP(445.5,SS,0),"^",2)="O",$O(^PRCP(445,"AH",ITEM,SS,""))>0 D GO
  1. ;
  1. N IME,SS
  1. I $P(^PRCP(445,SIP,0),"^",3)'="S" QUIT
  1. I '$D(^PRCP(445,SIP,1,ITEM)),ACTION'=2 QUIT
  1. S SS=$P($G(^PRCP(445,SIP,5)),"^",1) I SS']"" QUIT
  1. S IME=0
  1. ;
  1. GO N %,%H,%I,CNT,DATETIME,HLA,HLCS,HLEVN,HLFS,ITEMDATA,MC,NM,OUT,PRIM,SEG,X
  1. N MYRESULT,MYOPTNS
  1. I SIP>0,'+$P($G(^PRCP(445,SIP,1,ITEM,0)),"^",9),ACTION'=2 QUIT ; only deletes are valid for items with no normal
  1. S CNT=0,OUT=0
  1. ; if the supply station doesn't handle station specific data
  1. I SS>0,$P(^PRCP(445.5,SS,0),"^",2)="O",'PUSH D I OUT QUIT
  1. . ; I ACTION=3 S OUT=1 QUIT ; quit if editing station specific data
  1. . ; for add, quit if item is already on an IP in the SS
  1. . I ACTION=1 D
  1. . . N A,B
  1. . . S A=0
  1. . . S A=$O(^PRCP(445,"AH",ITEM,SS,"")) I +A'>0 S OUT=1 QUIT ; should have one
  1. . . I A'=SIP S OUT=1 QUIT ; item on a different IP in the SS
  1. . . I A=SIP S B=$O(^PRCP(445,"AH",ITEM,SS,A)) I +B>0 S OUT=1 QUIT
  1. . I ACTION=2 D I OUT=1 QUIT
  1. . . N A,B
  1. . . S A=0
  1. . . S A=$O(^PRCP(445,"AH",ITEM,SS,"")) I +A'>0 QUIT ; should find one
  1. . . I A'=SIP S OUT=1 QUIT ; item is on a different IP in the SS, don't delete from system
  1. . . I A=SIP S B=$O(^PRCP(445,"AH",ITEM,SS,A)) I +B>0 S OUT=1 QUIT ; item exists on another IP in the SS, don't delete from system
  1. . ; S SIP=0 ; flag to indicate revisions are not station specific
  1. ;
  1. ; set up environment for message
  1. 1 D INIT^HLFNC2("PRCP EV ITEM UPDATE",.HL)
  1. I $G(HL) D:'IME&MSG Q ; error occurred
  1. . D EN^DDIOL("The HL7 transaction cannot be built now.")
  1. . I ACTION=1,MSG D EN^DDIOL("You will need to add this item directly to the supply station.")
  1. . I ACTION=2,MSG D EN^DDIOL("You will need to delete this item from your supply station.")
  1. . I ACTION=3,MSG D EN^DDIOL("You must edit the item again later to update the supply station.")
  1. . D EN^DDIOL("Error: "_$P(HL,"^",2))
  1. S HLFS=$G(HL("FS")) I HLFS="" S HLFS="|"
  1. S HLCS=$E(HL("ECH"),1)
  1. ;
  1. I MSG D EN^DDIOL("Building HL7 "_($P("ADD,DELETE,EDIT",",",ACTION))_" Transaction on item#"_ITEM_" for "_$P(^PRCP(445.5,SS,0),"^",1))
  1. I MSG,SIP>0 D EN^DDIOL(" station "_$P(^PRCP(445,SIP,0),"^",1))
  1. ;
  1. ; create MFI segment
  1. 2 D NOW^%DTC S DATETIME=$P(%+17000000,".",1)_$P(%,".",2)
  1. S SEG="MFI"_HL("FS")
  1. S SEG=SEG_($S(SIP>0:445,1:441))_HL("FS")_HL("FS")
  1. S HLA("HLS",1)=SEG_"UPD"_HL("FS")_DATETIME_HL("FS")_HL("FS")_"NE"
  1. ;
  1. ; create MFE segment
  1. S SEG="MFE"_HL("FS")
  1. I ACTION=1 S SEG=SEG_"MAD"
  1. I ACTION=2 S SEG=SEG_"MDL"
  1. I ACTION=3 S SEG=SEG_"MUP"
  1. S SEG=SEG_HL("FS")_HL("FS")_HL("FS")
  1. S HLA("HLS",2)=SEG_ITEM_"~"_$P(^PRC(441,ITEM,0),"^",2)
  1. ;
  1. I SIP'>0 G 3 ; Z segment for station specific items only
  1. ;
  1. S ITEMDATA=""
  1. S ITEMDATA=^PRCP(445,SIP,1,ITEM,0)
  1. S PRIM=$P(ITEMDATA,"^",12) I PRIM']"" D
  1. . S PRIM=$O(^PRCP(445,"AB",SIP,""))
  1. . I PRIM]"" S PRIM=PRIM_";PRCP(445,"
  1. S NM=$P($G(^PRCP(445,SIP,1,ITEM,6)),"^",1)
  1. I NM']"",+PRIM>0 S NM=$P($G(^PRCP(445,+PRIM,1,ITEM,6)),"^",1)
  1. I NM']"" S NM=$P(^PRC(441,ITEM,0),"^",2)
  1. ;
  1. ; create Z segment
  1. S SEG="ZIM"_HL("FS")_ITEM_"~"_NM ; item# and description
  1. S SEG=SEG_HL("FS")_"~"_$P(^PRCP(445,SIP,0),"^",1) ; full station name
  1. S SEG=SEG_HL("FS")_$P(ITEMDATA,"^",9) ; normal level
  1. S SEG=SEG_HL("FS")_$P(ITEMDATA,"^",10) ; std reord pt
  1. S SEG=SEG_HL("FS")_$P(ITEMDATA,"^",11)_HL("FS") ; emergency
  1. I $P(ITEMDATA,"^",5)]"" S SEG=SEG_$P($G(^PRCD(420.5,$P(ITEMDATA,"^",5),0)),"^",1) ; unit of issue
  1. I PRIM]"" S X=$$GETVEN^PRCPUVEN(SIP,ITEM,PRIM,1)
  1. S X=$P(X,"^",4) I X']"" S X=1
  1. S SEG=SEG_HL("FS")_X ; pkg multiple (conversion factor)
  1. S HLA("HLS",3)=SEG_HL("FS")_$P(ITEMDATA,"^",15) ; last cost
  1. ;
  1. ;call HL7 to transmit message
  1. 3 S HLL("LINKS",1)="PRCP SU ITEM UPDATE"_"^"_$P(^PRCP(445.5,SS,0),"^",3)
  1. D GENERATE^HLMA("PRCP EV ITEM UPDATE","LM",1,.MYRESULT,"",.MYOPTNS)
  1. I MSG,$P(MYRESULT,"^",2,3)]"" D
  1. . ; error handler for message send failures
  1. . D EN^DDIOL("ERROR: "_MYRESULT)
  1. Q
  1. ;
  1. ; send all items in IP to supply station
  1. INIT D ^PRCPUSEL Q:'$G(PRCP("I"))
  1. I PRCP("DPTYPE")'="P" W !," This option may only be invoked from the Primary"
  1. N ACTION,DIR,DTOUT,DUOUT,INVPT,ITEM,PRCPINPT,Y
  1. INIT0 S INVPT=$$INVPT^PRCPUINV(PRC("SITE"),"S","","","") Q:'INVPT
  1. I $P($G(^PRCP(445,INVPT,5)),"^",1)']"" W !,"This option may only be run for supply station secondary inventory points." G INIT0
  1. ;
  1. ; ask initialize or update supply station items?
  1. S DIR("A",1)="This option sends information about ALL items with a normal stock"
  1. S DIR("A",2)="level greater than zero to the linked supply station. "
  1. S DIR("A",3)="You must flag the transactions as 'ADD' or 'EDIT'."
  1. S DIR("A",4)=""
  1. S DIR("A")="Select 'Add' OR 'Edit' transactions"
  1. S DIR(0)="SB^A:ADD;E:EDIT"
  1. D ^DIR
  1. I $D(DUOUT)!($D(DTOUT))!(Y']"") QUIT
  1. S ACTION=3 ; default to edit
  1. I Y="A" S ACTION=1
  1. ;
  1. S ITEM=0 F S ITEM=$O(^PRCP(445,INVPT,1,ITEM)) Q:'+ITEM D
  1. . I '$D(^PRCP(445,INVPT,1,ITEM,0)) QUIT
  1. . I +$P($G(^PRCP(445,INVPT,1,ITEM,0)),"^",9)=0 QUIT
  1. . D BLDSEG^PRCPHLFM(ACTION,ITEM,INVPT)
  1. . Q
  1. Q