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